squeak-image-3.8-6665/0000755000175000017500000000000010412205172013635 5ustar manthamanthasqueak-image-3.8-6665/ReadMe.txt0000755000175000017500000006347707740125730015572 0ustar manthamanthaIf you are not already reading this in Squeak, but wish to... Start Squeak and click in an open space to get the screen menu choose 'open...' then 'file list'. Select this file (ReadMe.txt) in the top right pane. The Squeak User Interface ---------------------------------- Windows To close a window, click on the "X" at the left side of its title bar. To collapse or expand a window, click on the "o" on the right side of its title bar. To change the name of a window, use the "change title..." command in the menu that pops up when you click on the menu icon to the right of the window close "X" in the title bar. This is for Morphic windows. If you are in an MVC project, the windows look slightly different but have similar controls. A window can be moved by dragging its title bar. To change the size of a window, move the mouse near a corner or border and, when a resizing icon appears, click and drag. Panes Many windows are made up of panes, and many of these have scroll bars, which can be on the left or on the right, and which can be permanently in place or of the flop-out variety (see Preferences.) The solid-colored rectangle can be dragged up and down to scroll the window contents. The up and down arrows at the ends of the scroll bar scroll one line at a time. The box with a "-" at the top of the scroll bar allows you to pop up a menu for that pane. Menus Pane menus (often different in different panes) can also be invoked by left-click (option-click on the Mac) in most panes. Many menu commands can also be invoked by cmd (alt) key combinations, indicated in the menus. The "desktop menu", also called the "screen menu" or the "World menu," can be invoked simply by clicking on the Squeak desktop outside of any window. Preferences There are numerous factors that influence the appearance and the behavior of Squeak. Many of them are governed by "Preferences", which are yes/no settings under your control. You can view and change preferences by opening a Preferences tool, either by dragging one out from the Tools flap or by choosing "preferences" from the "help..." branch of the desktop menu. Additionally, many appearance-related controls can be reached via the "appearance..." branch of the desktop menu. Themes A number of preferences can work together to create a whole "look and feel" to the user interface. Squeak gives you control at this level through support of "themes". Click on the 'Squeak' flap, and then on the 'choose theme...' button to choose another theme for your Squeak. A wimpy theme (outOfTheBox) was intentionally installed at release time (*) so that new users would be motivated to try other themes and, eventually, to define new ones of their own. Note many aspects of a new theme will only appear on windows created after the change. Therefore a good way to test a new theme is first to choose the theme, and then open a new browser or file list. [(*) Just kidding. No one agrees about such things, and a number of the creators of Squeak do not like the outOfTheBox setting. However it was agreed by all that there would be some value in choosing preferences that were not too shocking to new users of Squeak]. Color Squeak graphics support 1, 2, 4, 8, 16, and 32-bit color. To change the resolution of the Squeak screen, choose from the screen menu 'appearance...', 'set display depth...'. You will get the best performance if the Squeak screen depth matches the color setting of your monitor. Note that Squeak's 16-bit depth corresponds to "thousands of colors" and its 32-bit depth corresponds ot "millions of colors" or "24-bit color". Projects A project is an entire Squeak desktop full of windows. Projects are can be used to change quickly from one task to another. An inactive project is represented by a project window that shows a thumbnail of that project's windows. Project windows are actually more like doors than windows, since you can enter the project just by clicking on its project window. You can create a new project by choosing 'open...project' from the screen menu. To exit a project (and return to its parent project), choose 'previous project' from the screen menu. Each project maintains its set of windows, plus its own set of Smalltalk changes and its own screen color depth. A project can be stored on a Super Swiki, so projects are also the unit of sharing and publishing. Morphic Halos In a morphic project, cmd-click (alt-click) on a window or other graphical object will bring up a constellation of colored circles called "halo handles" around that object. Additional clicks will cycle through the halos for other graphical objects in the nesting structure. If you hold down the Shift key while cmd-clicking, the nested morphs will be traversed from innermost outward. Clicking without the cmd (alt) key will dismiss the halo. While the halo is up, letting the cursor linger over one of the halo handles for a few seconds will cause a balloon to pop up with the name of that handle. Three useful handles are the top-left "X" handle (delete), the bottom-right yellow handle (resize), and the brown handle (slide the object within its containing object). Halos allow complex graphical objects to be explored--or even disassembled (using the black halo handle). Usually no harm results from taking apart an object; you can just discard the pieces and create a new one. Flaps Tabs labeled "Squeak", "Tools", "Supplies", etc., will be found along the edges of the Squeak desktop. Click on any tab to open the corresponding flap. Drag a tab to resize the flap and to relocate the tab. Bring up the halo on any tab and click on its menu handle to be presented with many options relating to the flap. Use the "Flaps..." menu, reached via the desktop menu, to control which flaps are visible and for other flap-related options and assistance. Parts Bins You can obtain new objects in many ways. The "Objects Catalog" (choose "objects' from the desktop menu) and several of the standard flaps (e.g. "Tools" and "Supplies") serve as "Parts Bins" the for new objects. Drag any icon you see in a Parts Bin and a fresh copy of the kind of object it represents will appear "in your hand"; click to deposit the new object anywhere you wish. You can also add your own objects to any of the flaps -- just drag your object over the tab, wait for the flap to pop open, then drop the object at the desired position in the flap. Typing The assignment operator in Squeak, the "_" character, is really the ASCII underbar character, and that's how you type it. Note that the two-character string ":=" is an acceptable alternative for assignment. Similarly, the "^" is the ASCII caret character, usually typed as shift-6 on U.S. keyboards. The Squeak text editor supports many editing operations that can be invoked by command keys. For a full list of these operations, choose 'help...' from the desktop menu, then choose 'command-key help'. Try these out -- they will save you much time. The command key is the key marked with an Apple on Mac keyboard and the key marked "ALT" on other keyboards. Managing and Saving Changes ------------------------------------- Starting and Quitting Obviously you have figured out how to start the system. One way is to double-click on an image. If you have several different interpreters, you may want to drag the image to the appropriate interpreter; that lets you decide which interpreter should be used. To quit a Squeak session, choose 'quit' with or without saving from the desktop menu. If you save, your previous image file will be overwritten. You may choose 'save as...' or 'save as new version' to save a copy of your image and changes files with a new name (see below). Image File All of the objects -- classes, dictionaries, windows and other objects -- that make up the Squeak environment are stored in an image file (this must be named 'SomeName.image' or 'SomeName.ima'). When you start up an image, everything is right where you left it when you last saved that image. Sources and Changes The source code associated with the Squeak code in an image file is stored in two other files. The code of the base system (e.g., Squeak version 3.0) is stored in the file 'SqueakV3.sources', and the sources for methods added or changed since that time are in the changes file (which must similarly be named 'SomeName.changes'). Storing the source code in a separate file has several advantages. To begin with, if you have been working for a couple of hours, and your dog pulls out the power cord, you will still have a sequential record of all your program edits, and these can be perused and replayed to recover your work. This feature has also saved many a hacker who got too adventurous while changing the system he or she was using. However, if you wish to run the system with severely limited resources, it can be operated without any source code, owing to its ability to decompile the bytecode methods into a readable and editable version of the original source code (only comments and temporary variable names are lost). Finally, since the changes file does not consume memory space, Squeak keeps a complete history of all your program changes. This makes it easy to examine or even reinstate older versions of methods (see 'versions' option in browser selector pane). This encourages experimentation, since you can easily revert to the original versions of any set of methods. FileOut, FileIn In addition to the 'save' command that saves the entire state of your Squeak image, individual methods, categories and classes may be 'filed out'. Filing out a method, category, or class results in the creation of a text file containing the code in question. This file can be read into the same or another Squeak image to recreate the saved classes and methods. ChangeLists, ChangeSets, and ChangeSorters A ChangeList is a method-by-method view of a fileOut. Note that the changes file records all your programming actions using the same fileOut format, so a ChangeList can browse the change history of any Squeak image. The "recently logged changes" command of the changes... menu is one way to do this. You can also open a ChangeList on any fileOut file by selecting the file in the FileList and selecting the "browse changes" command. In addition to the image-wide record of changes kept in the changes file, a record of changes is also associated with every project. This "change set" records only the class and method changes you made within that project. This allows you to make a fileOut of all the changes that constitute your work on that project. Single and dual ChangeSorters allow one to examine the change set of the current project and other projects, and also allows changes to be moved between change sets. These are very useful tools for more experienced Squeak programmers. Organizing your Disk Squeak will look for the sources file either in the folder containing the image. If the sources file is not found there, then it looks in the folder containing the VM. In general, it is simplest to keep a single copy of the sources file in the folder containing the VM. You can use any number of image/changes pairs anywhere on your disk. If you wish to maintain several versions of the VM, here is the easiest way: place all VMs in one folder along with the sources file. Then, in each folder with images for version X, place an alias of the VM for version X. You can then start VM version X on that image by dragging the image onto the VM alias. (If you start Squeak by double-clicking on the image, it might use the wrong version of the VM to run that image.) Another technique is to keep an alias for your favorite VM on the desktop and start images by dropping them on this alias. These instructions apply to Mac and Windows, but the same general strategy can be applied to Linux, Unix, and many other platforms. Morphic and MVC --------------------- Squeak has two completely independent user interface frameworks, each with its own window system. The newer Morphic framework is the locus current development and most of the interesting facilities, such as end-user scripting, work only in Morphic. However, the older "Model-View-Controller" (MVC) framework is still a viable Smalltalk programming environment and may perform better on slower machines and when memory is extremely limited. The choice of frameworks is made when you create a project using the "open..." command on the screen menu. You can have any mixture of Morphic and MVC projects within an image. Brainstorming and Engineering ------------------------------------- The Squeak team works in periods of expansion, when we try new approaches and write lots of new code, and periods of reflection, where we re-factor, clean up and document (well... when there's nothing else to do ;-). It is important for critics to understand that the morphic system and the end-user programming systems that are embedded in it, are still in an expanding brainstorming phase. We know that the morphic protocols are overgrown and unwieldy. But there's a good reason for this. Morphic is being taken in new directions, including flexing, scripting, and viewing. When we have gained experience with these new areas, when we have done some testing with real users, when we better understand the real kernel of this new architecture, then we will clean up and simplify the architecture. Source Code Updates ------------------------ Tired of waiting months for the next release? You can load the latest updates automatically into any Squeak attached to the internet. Just hit 'load code updates' in the Squeak flap, or choose 'update code from server' in the 'help...' menu. The Squeak team periodically releases approved changes to Squeak to the update servers. Updates are numbered and are loaded in order. Active Squeak developers work with an advanced version of Squeak for which new updates are issued weekly or even daily. If you wish to participate as a "test pilot" in this process, you should join the Squeak mailing list (described on Squeak.org), get a current "test pilot" image, and watch for announcements of new updates. If you wish to set up your own Update server for your own organization, please contact Ted Kaehler. It is an easy way to distribute changes to a group of people using Squeak. Image Size -------------- We have intentionally included more features with the Squeak 3.5 release than most people will use. If space is of concern, many of these facilities can be removed to produce a considerably smaller image. We are in the process of sanitizing and automating this removal process. Right now, if you fileIn MajorShrinkFor3.0.cs, and follow the instructions, you should end up with an image that is around 870k. It will not have Morphic in it, and there will be loose ends in the image that may cause errors when you attempt to use facilities that have been removed, but this is usually not fatal. The shrunken image has compiled method temp names into a compact trailer on every method, allowing the entire system to be browsed by decompiling with temp names preserved. This means there is no need to store the sources file on small machines. While comments are not available after abandoning sources, all the code you write will be preserved properly in the changes file, so that you can upload it to a full Squeak when you return from your backpack trip. We will be updating the various shrinking routines to improve this process, and they can be browsed in the 'shrinking' category of SystemDictionary. If you simply want a small image to play with, search for the mini2.2 image on the Squeak servers. It is quite complete and only 600K. The Squeak Wiki Wiki Server ----------------------------------- Ward Cunningham invented the idea of a web server with pages that any user can modify. He called it the "Wiki Wiki" server, after the Hawaiian word for "quick". Mark Guzdial and his students at Georgia Tech implemented a Wiki Wiki server in Squeak, which we call a "swiki". Every web page on a Swiki web site has a button that says, "Edit this Page". It gives you the contents of that page in a scrolling window. If you edit this text and hit "Save", the page is stored back on the server with your changes. This can work from any web browser. Changing a page is easy enough that a workgroup, class, or organization can quickly create and maintain an evolving web site of its own pages. To start your own Swiki, see the instructions in (PWS class howToStart), and get a folder with necessary template files from... http://www.cc.gatech.edu/fac/mark.guzdial/squeak/pws/ Many thanks to Georg Gollmann, Mark Guzdial, Mark's students, and to the father of the Wiki Wiki, Ward Cunningham. Stylized Text and Links in Source Code -------------------------------------------- Squeak allows creation of hyperlinks in text, and preserves them (and most text styles) in source code and class comments! This makes it possible to document Squeak more effectively than before, as you will see from the limited examples in the Sample Documentation window. Links can be created using CMD-6, and they can deactivated by selecting (with an extra leading character, or from back to front) and using CMD-0. If you never put links or emphasis in your source code, everything should work just as before. FileOuts may include style information after each method. If you need to bring a new fileOut into an older system, read the file 'readFileinsWithStyle.cs' into your older system first. Sources of Information --------------------------- Basic help information is available in two external media: (1) The ReadMe.txt file, which contains exactly the content you are currently reading. (2) You will also find lots of other useful and possibly more current information on the Georgia Tech Swiki server. We thank Mark Guzdial at Georgia Tech for making this server available. You can browse it in any web browser using the URL below, or, if you enjoy using Squeak for everything, just click on... http://minnow.cc.gatech.edu/Squeak.1 In addition, you will likely want to browse other sites on the web, including... http://www.squeak.org/ -- The Squeak home page and UIUC archive http://www.create.ucsb.edu/squeak/ -- Stephen Pope's U.S. mirror site at UCSB. ftp://st.cs.uiuc.edu/Smalltalk/Squeak/ -- The Squeak archive at UIUC. http://www.sugarWeb.com -- Smalltalk User Group of Argentina (SUGAR) Text of the Welcome Window ---------------------------------- In case you delete your welcome window, and wish to retrieve it for one reason or another, here is the text from that window, as released... Squeak 3.6 (Full) Squeak is a rapidly moving project based on Smalltalk-80, with which it is still reasonably compatible. Squeak includes a full integrated development environment, networking, sound synthesis and sampling, speech synthesis, 2 & 3D graphics, arithmetic and data structure libraries. It even incorporates tools to produce the core code for its own virtual machine so that you can build your own VM. Browser openBrowser [Blue items in this window are active text. If an item contains a URL, it will require internet access and may take a while to load]. Not only is all source code included, and changeable at will, it is also completely open and free. The Squeak system image runs bit-identically across all platforms, and VMs are available for just about every computer and operating system available. The history of the Squeak project can be read at ftp://st.cs.uiuc.edu/Smalltalk/Squeak/docs/OOPSLA.Squeak.html The Squeak license and most other relevant information can be found on the Squeak Home Page, http://www.Squeak.org The "Full" Release vs. the "Basic" Release As of version 3.6, there are now two configurations for the official Squeak release. You are most likely using the Full release, which is filled with multimedia, developer, and educational content, similar to previous Squeak releases. This is the default release which is available from www.squeak.org. However, there is also a slimmed-down Basic release available with some of this content removed, which is useful if you need a smaller footprint with which to develop Squeak applications. A goal of the Squeak Guides is to strip down the Basic release until it contains just the essential developer tools. Beyond that, at some point in the future there will also be a "Minimal" release available containing just the core language kernel. SqueakMap An exciting feature which has recently been made available is SqueakMap, a package catalog system for Squeak. As of this release, over 300 packages/applications have been added to SqueakMap by members of the Squeak community. You can easily browse and install these packages directly in Squeak by using the SqueakMap Package Loader, which is available from the "open..."/"Package Loader" menu (or, by clicking here). For more information on SqueakMap, see http://minnow.cc.gatech.edu/squeak/squeakmap. Morphic This release of Squeak uses the Morphic graphics architecture. Squeak also includes an MVC architecture available inside MVC projects (see the world menu 'open...' options). Most of the standard system windows can be opened in either framework, but media support is much more highly developed in Morphic. In addition, the Morphic framework includes Genie, a character and gesture recognition system that allows you to control everything in Squeak by just using a pen. Click on: AGenieIntroduction. Projects Projects are separate worlds within Squeak, similar to pages on the Internet. In fact active projects can be shared over the internet just like web pages. We have included a number of demonstration projects in the 'Worlds of Squeak' window. Other projects may be found by selecting the 'FIND' button under the Navigator tab at the bottom of the screen. To 'Go Back' from a project you have entered, choose 'previous project' from the world menu, or '< PREV' from the navigator tab. Color graphics Squeak's BitBlt has been retrofitted with support for variable-depth color and many performance enhancements. It has several added functions including a paint mode that supports transparency, and an alpha-blend mode for 32-bit color. It also has a "warp-drive" variant that will scale, rotate, and otherwise deform bitmaps in a single pass. Interested users will want to try Display restoreAfter: [WarpBlt test1] and Display restoreAfter: [WarpBlt test3]. Sound Squeak includes base classes and some simple primitives that support real-time background generation of sound and music. Interested users may want to try AbstractSound stereoBachFugue play. as well as the examples in the Worlds of Squeak. Balloon Squeak now includes a completely new outline-based graphics subsystem named Balloon. Balloon graphics are independent of scale and rotation, and may be rendered simply or with 2 degrees of anti-aliasing. For a quick demonstration, click on... (FlashMorphReader on: (HTTPSocket httpGet: 'http://www.squeak.org/Squeak3.4/areallycoolflash.swf' accept:'application/x-shockwave-flash')) processFile startPlaying openInWorld. This example (courtesy of Herves Flores (email - herve.flores@free.fr; web site - http://herve.flores.online.fr) also demonstrates that Squeak includes a fairly complete implementation of the Flash3 graphics file format, with conversion to Balloon graphical objects. Since it's all in Squeak, you can stop the player and take apart the morphic balloon objects. (NOTE: The Balloon Flash player will only play Flash3 files -- not Flash4 or Flash5.) Networking Squeak supports network access. If you are on a web-connected network, you might want to try... HTTPSocket httpShowGif: 'http://squeak.org/Squeak2.0/midi/Squeakers.GIF'. There are more examples in the Socket class. Also included with this release is a complete WikiWiki server. See the accompanying information on WikiWiki. Squeak's FileList also supports network access. Available servers are shown at the [] root, and new servers can be added with the 'add server...' menu command. Finally, as mentioned above, Squeak can download active projects over the net... Project fromUrl: 'http://209.143.91.36/super/SuperSwikiProj/FinalFrontier'. Development support Squeak includes a mature program development system. Most of the components of this system can be found in the world menu 'open...' options. Most of the available functions can be surveyed in various menu choices, and also in the world menu 'help...' / 'command-key help' option. Shrinking Squeak If you wish to unload the "Worlds of Squeak" examples from this image, make a backup copy, execute the following five lines, close the window, and then save the resulting image... ProjectViewMorph allInstancesDo: [:m | (m hasProperty: #deleteWorldsOfSqueak) ifTrue: [Project deletingProject: m project. m delete]]. Project rebuildAllProjects. ScriptingSystem spaceReclaimed It is possible to shrink Squeak much more than this. Earlier releases of Squeak came with a specially-prepared fileIn, with a name such as "MajorShrinkFor3.0.cs", which, when applied as described in accompanying instructions, could create an image that is under 1MB in size. Squeak 3.6 does not come with such a majorShrink file-in, but you could use an earlier version of majorShrink as a point of departure, or, better still, search for up-to-date information about shrinking on the Squeak swiki. Here is a good point of departure: http://minnow.cc.gatech.edu/squeak/majorshrink Further Documentation - The Swiki The Squeak Swiki at Georgia Tech is currently the primary source of online documentation and community information regarding Squeak. It contains a FAQ, tutorials, and much more. Visit it at: http://minnow.cc.gatech.edu/squeak The Squeak License Squeak is distributed for use and modification subject to a liberal open source license. http://squeak.org/license.html. Unless stated to the contrary, works submitted for incorporation into or for distribution with Squeak shall be presumed subject to the same license. Portions of Squeak are: Copyright (c) 1996 Apple Computer, Inc. Copyright (c) 1997-2001 Walt Disney Company, and/or Copyrighted works of other contributors. All rights reserved. squeak-image-3.8-6665/Squeak3.8-6665full.changes0000644000175000017500006615347310266214422020176 0ustar manthamantha'From Squeak3.8gamma of ''24 November 2004'' [latest update: #6639] on 6 April 2005 at 11:54:28 am'! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'! bytesPerEncodedFrame "Answer the number of bytes required to hold one frame of compressed sound data." "Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes." | bitCount | frameSizeMask = 0 ifTrue: [^ bitsPerSample]. "Following assumes mono:" bitCount _ 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample). ^ (bitCount + 7) // 8 ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/14/2001 11:21'! reset self resetForMono. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'jm 11/21/2001 11:35'! encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag | stereoFlag sampleCount sampleBitCount bitCount | self initializeForBitsPerSample: bits samplesPerFrame: frameSize. stereoFlag _ rightSoundBuffer notNil. sampleCount _ leftSoundBuffer monoSampleCount. stereoFlag ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)] ifFalse: [sampleBitCount _ sampleCount * bitsPerSample]. bitCount _ sampleBitCount + (self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag). encodedBytes _ ByteArray new: ((bitCount / 8) ceiling roundUpTo: self bytesPerEncodedFrame). byteIndex _ 0. bitPosition _ 0. currentByte _ 0. flashFlag ifTrue: [self nextBits: 2 put: bits - 2]. stereoFlag ifTrue: [ samples _ Array with: leftSoundBuffer with: rightSoundBuffer. sampleIndex _ Array with: 0 with: 0. self privateEncodeStereo: sampleCount] ifFalse: [ samples _ leftSoundBuffer. sampleIndex _ 0. self privateEncodeMono: sampleCount]. ^ encodedBytes ! ! !ADPCMCodec methodsFor: 'private' stamp: 'zz 3/2/2004 07:58'! indexForDeltaFrom: thisSample to: nextSample "Answer the best index to use for the difference between the given samples." "Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63." "Note: Since there does not appear to be any documentation of how Flash actually computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder." | diff bestIndex | self inline: true. diff _ nextSample - thisSample. diff < 0 ifTrue: [diff _ 0 - diff]. bestIndex _ 63. 1 to: 62 do: [:j | bestIndex = 63 ifTrue: [ (stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]]. ^ bestIndex ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateDecodeMono: count | delta step predictedDelta bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predicted _ self nextBits: 16. predicted > 32767 ifTrue: [predicted _ predicted - 65536]. index _ self nextBits: 6. samples at: (sampleIndex _ sampleIndex + 1) put: predicted] ifFalse: [ delta _ self nextBits: bitsPerSample. step _ stepSizeTable at: index + 1. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. (delta bitAnd: deltaSignMask) > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predicted]]. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateDecodeStereo: count | predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. self var: #rightSamples declareC: 'short int *rightSamples'. self var: #predicted declareC: 'short int *predicted'. self var: #index declareC: 'short int *index'. "make local copies of decoder state variables" predictedLeft _ predicted at: 1. predictedRight _ predicted at: 2. indexLeft _ index at: 1. indexRight _ index at: 2. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predictedLeft _ self nextBits: 16. indexLeft _ self nextBits: 6. predictedRight _ self nextBits: 16. indexRight _ self nextBits: 6. predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536]. predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight] ifFalse: [ deltaLeft _ self nextBits: bitsPerSample. deltaRight _ self nextBits: bitsPerSample. stepLeft _ stepSizeTable at: indexLeft + 1. stepRight _ stepSizeTable at: indexRight + 1. predictedDeltaLeft _ predictedDeltaRight _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (deltaLeft bitAnd: bit) > 0 ifTrue: [ predictedDeltaLeft _ predictedDeltaLeft + stepLeft]. (deltaRight bitAnd: bit) > 0 ifTrue: [ predictedDeltaRight _ predictedDeltaRight + stepRight]. stepLeft _ stepLeft bitShift: -1. stepRight _ stepRight bitShift: -1. bit _ bit bitShift: -1]. predictedDeltaLeft _ predictedDeltaLeft + stepLeft. predictedDeltaRight _ predictedDeltaRight + stepRight. (deltaLeft bitAnd: deltaSignMask) > 0 ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft] ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft]. (deltaRight bitAnd: deltaSignMask) > 0 ifTrue: [predictedRight _ predictedRight - predictedDeltaRight] ifFalse: [predictedRight _ predictedRight + predictedDeltaRight]. predictedLeft > 32767 ifTrue: [predictedLeft _ 32767] ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]]. predictedRight > 32767 ifTrue: [predictedRight _ 32767] ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]]. indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1). indexLeft < 0 ifTrue: [indexLeft _ 0] ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]]. indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1). indexRight < 0 ifTrue: [indexRight _ 0] ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight]]. "save local copies of decoder state variables" predicted at: 1 put: predictedLeft. predicted at: 2 put: predictedRight. index at: 1 put: indexLeft. index at: 2 put: indexRight. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:11'! privateEncodeMono: count | step sign diff delta predictedDelta bit p | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. step _ stepSizeTable at: 1. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ predicted _ samples at: (sampleIndex _ sampleIndex + 1). (p _ predicted) < 0 ifTrue: [p _ p + 65536]. self nextBits: 16 put: p. i < count ifTrue: [ index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)]. self nextBits: 6 put: index. ] ifFalse: [ "compute sign and magnitude of difference from the predicted sample" sign _ 0. diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted. diff < 0 ifTrue: [ sign _ deltaSignMask. diff _ 0 - diff]. "Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates: delta _ (4 * diff) / step. predictedDelta _ ((delta + 0.5) * step) / 4; but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines." delta _ 0. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ diff >= step ifTrue: [ delta _ delta + bit. predictedDelta _ predictedDelta + step. diff _ diff - step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. "compute and clamp new prediction" sign > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. "compute new index and step values" index _ index + (indexTable at: delta + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. step _ stepSizeTable at: index + 1. "output encoded, signed delta" self nextBits: bitsPerSample put: (sign bitOr: delta)]]. bitPosition > 0 ifTrue: [ "flush the last output byte, if necessary" encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte]. ! ! !ADPCMCodec methodsFor: 'private' stamp: 'ar 4/23/2001 15:12'! privateEncodeStereo: count "not yet implemented" self inline: false. self success: false.! ! !ADPCMCodec commentStamp: '' prior: 0! This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the algorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives. This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.) ! !ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'! newBitsPerSample: bitsPerSample ^ super new initializeForBitsPerSample: bitsPerSample samplesPerFrame: 0. ! ! !AIFFFileReader methodsFor: 'reading' stamp: 'jm 10/17/2001 17:20'! readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:." "AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true" | f | f _ (FileStream readOnlyFileNamed: fileName) binary. self readFromStream: f mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag. f close. ! ! !AIFFFileReader methodsFor: 'reading'! readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read an AIFF file from the given binary stream. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data." mergeIfStereo _ mergeFlag. skipDataChunk _ skipDataFlag. isLooped _ false. gain _ 1.0. self readFrom: aBinaryStream. ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 10/20/2001 15:07'! channelDataOffset ^ channelDataOffset ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 10/20/2001 15:07'! readSamplesChunk: chunkSize "Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type." | offset blockSize bytesOfSamples s | offset _ in nextNumber: 4. blockSize _ in nextNumber: 4. ((offset ~= 0) or: [blockSize ~= 0]) ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks']. bytesOfSamples _ chunkSize - 8. bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8)) ifFalse: [self error: 'actual sample count does not match COMM chunk']. channelDataOffset _ in position. "record stream position for start of data" skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self]. "if skipDataChunk, skip sample data" (mergeIfStereo and: [channelCount = 2]) ifTrue: [ channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)] ifFalse: [ channelData _ (1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]]. (bytesOfSamples < (Smalltalk garbageCollectMost - 300000)) ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)] "bulk-read, then process" ifFalse: [s _ in]. "not enough space to buffer; read directly from file" "mono and stereo are special-cased for better performance" channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s]. channelCount = 2 ifTrue: [ mergeIfStereo ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s] ifFalse: [^ self readStereoChannelDataFrom: s]]. self readMultiChannelDataFrom: s. ! ! !Abort methodsFor: 'as yet unclassified' stamp: 'ajh 3/24/2003 00:55'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:10'! changeKind ^self class changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:43'! environmentAt: anItemKind (self itemKind = anItemKind) ifTrue: [^self item]. ^environment at: anItemKind ifAbsent: [nil]! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:20'! eventSelector ^self class eventSelectorBlock value: itemKind value: self changeKind! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! item: anItem kind: anItemKind item := anItem. itemKind := anItemKind. environment := Dictionary new! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:37'! itemCategory: aCategory environment at: self class categoryKind put: aCategory! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:36'! itemClass: aClass environment at: self class classKind put: aClass! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 12:11'! itemExpression: anExpression environment at: self class expressionKind put: anExpression! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemMethod: aMethod environment at: self class methodKind put: aMethod! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'rw 7/10/2003 12:38'! itemProtocol: aProtocol environment at: self class protocolKind put: aProtocol! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor: requestor environment at: #requestor put: requestor! ! !AbstractEvent methodsFor: 'private-accessing' stamp: 'NS 1/27/2004 10:39'! itemSelector: aSymbol environment at: #selector put: aSymbol! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! item "Return the item that triggered the event (typically the name of a class, a category, a protocol, a method)." ^item! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemCategory ^self environmentAt: self class categoryKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:43'! itemClass ^self environmentAt: self class classKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 12:10'! itemExpression ^self environmentAt: self class expressionKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 6/30/2003 08:22'! itemKind "Return the kind of the item of the event (#category, #class, #protocol, #method, ...)" ^itemKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemMethod ^self environmentAt: self class methodKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:44'! itemProtocol ^self environmentAt: self class protocolKind! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemRequestor ^self environmentAt: #requestor! ! !AbstractEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 10:38'! itemSelector ^self environmentAt: #selector! ! !AbstractEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:52'! printOn: aStream self printEventKindOn: aStream. aStream nextPutAll: ' Event for item: '; print: self item; nextPutAll: ' of kind: '; print: self itemKind! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isAdded ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 18:41'! isCategoryKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/10/2003 15:01'! isCommented ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! isDoIt ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! isModified ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/21/2004 09:40'! isProtocolKnown ^self itemCategory notNil! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:53'! isRecategorized ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:34'! isRemoved ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:35'! isRenamed ^false! ! !AbstractEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! isReorganized ^ false! ! !AbstractEvent methodsFor: 'triggering' stamp: 'rw 7/14/2003 17:06'! trigger: anEventManager "Trigger the event manager." anEventManager triggerEvent: self eventSelector with: self.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass ^ self item: aClass kind: AbstractEvent classKind.! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 18:42'! class: aClass category: cat | instance | instance := self class: aClass. instance itemCategory: cat. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 11:19'! item: anItem kind: anItemKind ^self basicNew item: anItem kind: anItemKind! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:19'! method: aMethod class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/16/2004 14:20'! method: aMethod protocol: prot class: aClass | instance | instance := self method: aMethod class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:48'! method: aMethod selector: aSymbol class: aClass | instance | instance := self item: aMethod kind: self methodKind. instance itemSelector: aSymbol. instance itemClass: aClass. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:49'! method: aMethod selector: aSymbol protocol: prot class: aClass | instance | instance := self method: aMethod selector: aSymbol class: aClass. instance itemProtocol: prot. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 10:50'! method: aMethod selector: aSymbol protocol: prot class: aClass requestor: requestor | instance | instance := self method: aMethod selector: aSymbol protocol: prot class: aClass. instance itemRequestor: requestor. ^instance! ! !AbstractEvent class methodsFor: 'instance creation' stamp: 'rw 6/30/2003 09:20'! new "Override new to trigger an error, since we want to use specialized methods to create basic and higher-level events." ^self error: 'Instances can only be created using specialized instance creation methods.'! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'NS 1/16/2004 14:08'! allChangeKinds "AbstractEvent allChangeKinds" ^AbstractEvent allSubclasses collect: [:cl | cl changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'bvs 7/20/2004 12:12'! allItemKinds "self allItemKinds" ^(AbstractEvent class organization listAtCategoryNamed: #'item kinds') collect: [:sel | self perform: sel]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! changeKind "Return a symbol, with a : as last character, identifying the change kind." self subclassResponsibility! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:18'! eventSelectorBlock ^[:itemKind :changeKind | itemKind, changeKind, 'Event:']! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:19'! itemChangeCombinations ^self supportedKinds collect: [:itemKind | self eventSelectorBlock value: itemKind value: self changeKind]! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:04'! supportedKinds "All the kinds of items that this event can take. By default this is all the kinds in the system. But subclasses can override this to limit the choices. For example, the SuperChangedEvent only works with classes, and not with methods, instance variables, ..." ^self allItemKinds! ! !AbstractEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:39'! systemEvents "Return all the possible events in the system. Make a cross product of the items and the change types." "self systemEvents" ^self allSubclasses inject: OrderedCollection new into: [:allEvents :eventClass | allEvents addAll: eventClass itemChangeCombinations; yourself]! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! categoryKind ^#category! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! classKind ^#class! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/14/2003 11:41'! expressionKind ^#expression! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/9/2003 11:12'! methodKind ^#method! ! !AbstractEvent class methodsFor: 'item kinds' stamp: 'rw 7/10/2003 12:36'! protocolKind ^#protocol! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:23'! comment1 "Smalltalk organization removeElement: #ClassForTestingSystemChanges3 Smalltalk garbageCollect Smalltalk organizati classify:under: SystemChangeNotifier uniqueInstance releaseAll SystemChangeNotifier uniqueInstance noMoreNotificationsFor: aDependent. aDependent := SystemChangeNotifierTest new. SystemChangeNotifier uniqueInstance notifyOfAllSystemChanges: aDependent using: #event: SystemChangeNotifier uniqueInstance classAdded: #Foo inCategory: #FooCat | eventSource dependentObject | eventSource := EventManager new. dependentObject := Object new. register - dependentObject becomes dependent: eventSource when: #anEvent send: #error to: dependentObject. unregister dependentObject: eventSource removeDependent: dependentObject. [eventSource triggerEvent: #anEvent] on: Error do: [:exc | self halt: 'Should not be!!']."! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 10:24'! comment2 "HTTPSocket useProxyServerNamed: 'proxy.telenet.be' port: 8080 TestRunner open -------------------- We propose two orthogonal groups to categorize each event: (1) the 'change type': added, removed, modified, renamed + the composite 'changed' (see below for an explanation) (2) the 'item type': class, method, instance variable, pool variable, protocol, category + the composite 'any' (see below for an explanation). The list of supported events is the cross product of these two lists (see below for an explicit enumeration of the events). Depending on the change type, certain information related to the change is always present (for adding, the new things that was added, for removals, what was removed, for renaming, the old and the new name, etc.). Depending on the item type, information regarding the item is present (for a method, which class it belongs to). Certain events 'overlap', for example, a method rename triggers a class change. To capture this I impose a hierarchy on the 'item types' (just put some numbers to clearly show the idea. They don't need numbers, really. Items at a certain categories are included by items one category number higher): level 1 category level 2 class level 3 instance variable, pool variable, protocol, method. Changes propagate according to this tree: any 'added', 'removed' or 'renamed' change type in level X triggers a 'changed' change type in level X - 1. A 'modified' change type does not trigger anything special. For example, a method additions triggers a class modification. This does not trigger a category modification. Note that we added 'composite events': wildcards for the 'change type' ('any' - any system additions) and for the 'item type' ('Changed' - all changes related to classes), and one for 'any change systemwide' (systemChanged). This result is this list of Events: classAdded classRemoved classModified classRenamed (?) classChanged (composite) methodAdded methodRemoved methodModified methodRenamed (?) methodChanged (composite) instanceVariableAdded instanceVariableRemoved instanceVariableModified instanceVariableRenamed (?) instanceVariableChanged (composite) protocolAdded protocolRemoved protocolModified protocolRenamed (?) protocolChanged (composite) poolVariableAdded poolVariableRemoved poolVariableModified poolVariableRenamed (?) poolChanged (composite) categoryAdded categoryRemoved categoryModified categeryRenamed (?) categoryChanged (composite) anyAdded (composite) anyRemoved (composite) anyModified (composite) anyRenamed (composite) anyChanged (composite) To check: can we pass somehow the 'source' of the change (a browser, a file-in, something else) ? Maybe by checking the context, but should not be too expensive either... I found this useful in some of my tools, but it might be too advanced to have in general. Tools that need this can always write code to check it for them. But is not always simple... Utilities (for the recent methods) and ChangeSet are the two main clients at this moment. Important: make it very explicit that the event is send synchronously (or asynchronously, would we take that route). category class comment protocol method OR category Smalltalk class comment protocol method ?? Smalltalk category \ / class / | \ comment | protocol | / method "! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'rw 7/11/2003 15:43'! comment3 "Things to consider for trapping: ClassOrganizer>>#changeFromCategorySpecs: Problem: I want to trap this to send the appropriate bunch of ReCategorization events, but ClassOrganizer instances do not know where they belong to (what class, or what system); it just uses symbols. So I cannot trigger the change, because not enough information is available. This is a conceptual problem: the organization is stand-alone implementation-wise, while conceptually it belongs to a class. The clean solution could be to reroute this message to a class, but this does not work for all of the senders (that would work from the browserm but not for the file-in). Browser>>#categorizeAllUncategorizedMethods Problem: should be trapped to send a ReCategorization event. However, this is model code that should not be in the Browser. Clean solution is to move it out of there to the model, and then trap it there (or reroute it to one of the trapped places). Note: Debugger>>#contents:notifying: recompiles methods when needed, so I trapped it to get updates. However, I need to find a way to write a unit test for this. Haven't gotten around yet for doing this though... "! ! !AbstractEvent class methodsFor: 'temporary' stamp: 'sd 3/9/2004 19:42'! saveChangeNotificationAsSARFileWithNumber: aNumber "Use the SARBuilder package to output the SystemChangeNotification stuff as a SAR file. Put this statement here so that I don't forget it when moving between images :-)" "self saveChangeNotificationAsSARFileWithNumber: 6" | filename changesText readmeText dumper | filename := 'SystemchangeNotification'. dumper _ self class environment at: #SARChangeSetDumper ifAbsent: [ ^self ]. changesText := ' 0.6 Version for Squeak 3.7 (no longer for 3.6!!!!) Changed one hook method to make this version work in Squeak3.7. Download version 5 from http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar if you are working with Squeak 3.6. 0.5 Updated the safeguard mechanism so that clients with halts and errors do not stop all notifications. Added and updated new tests for this. If this interests you have a look at the class WeakActionSequenceTrappingErrors. 0.4 Ported to Squeak 3.6. 0.3 Added the hooks for instance variables (addition, removal and renaming). Refactored the tests. 0.2 Added hooks and tests for method removal and method recategorization. 0.1 First release'. readmeText := 'Implements (part of) the system change notification mechanism. Clients that want to receive notifications about system changes should look at the category #public of the class SystemChangeNotifier, and the unit tests. VERY IMPORTANT: This version is for Squeak 3.7 only. It will not work in Squeak version 3.6. Download and install the last version that worked in Squeak 3.6 (version 5) from the following URL: http://www.iam.unibe.ch/~wuyts/SystemchangeNotification5.sar'. (dumper on: Project current changeSet including: (ChangeSorter allChangeSetNames select: [:ea | 'SystemChangeHooks' match: ea])) changesText: changesText; readmeText: readmeText; fileOutAsZipNamed: filename , aNumber printString , '.sar'! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! ascent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! ascentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! basicAscentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! basicDescentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descentOf: aCharacter ^ self descent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:15'! familyName "Answer the name to be used as a key in the TextConstants dictionary." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! height "Answer the height of the receiver, total of maximum extents of characters above and below the baseline." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! lineGrid "Answer the relative space between lines" ^self subclassResponsibility! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:33'! pixelSize "Make sure that we don't return a Fraction" ^ TextStyle pointsToPixels: self pointSize! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize self subclassResponsibility.! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 7/11/2004 21:15'! textStyle ^ TextStyle actualTextStyles detect: [:aStyle | aStyle fontArray includes: self] ifNone: [ TextStyle fontArray: { self } ]! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 3/22/2004 15:15'! textStyleName "Answer the name to be used as a key in the TextConstants dictionary." ^self familyName! ! !AbstractFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:36'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) display context." ^self subclassResponsibility! ! !AbstractFont methodsFor: 'measuring' stamp: 'tak 1/11/2005 17:20'! approxWidthOfText: aText "Return the width of aText -- quickly, and a little bit dirty. Used by lists morphs containing Text objects to get a quick, fairly accurate measure of the width of a list item." | w | (aText isNil or: [aText size == 0 ]) ifTrue:[^0]. w _ self widthOfString: aText asString. "If the text has no emphasis, just return the string size. If it is empasized, just approximate the width by adding about 20% to the width" (((aText runLengthFor: 1) == aText size) and: [(aText emphasisAt: 1) == 0 ]) ifTrue:[^w] ifFalse:[ ^w * 6 // 5 ]. ! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 14:25'! widthOfString: aString aString ifNil:[^0]. ^self widthOfString: aString from: 1 to: aString size. " TextStyle default defaultFont widthOfString: 'zort' 21 "! ! !AbstractFont methodsFor: 'measuring' stamp: 'ar 12/31/2001 00:54'! widthOfString: aString from: startIndex to: stopIndex "Measure the length of the given string between start and stop index" | character resultX | resultX _ 0. startIndex to: stopIndex do:[:i | character _ aString at: i. resultX _ resultX + (self widthOf: character)]. ^resultX! ! !AbstractFont methodsFor: 'measuring' stamp: 'sps 3/23/2004 15:50'! widthOfStringOrText: aStringOrText aStringOrText ifNil:[^0]. ^aStringOrText isText ifTrue:[self approxWidthOfText: aStringOrText ] ifFalse:[self widthOfString: aStringOrText ] ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! !AbstractFont methodsFor: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !AbstractFont class methodsFor: 'as yet unclassified' stamp: 'nk 9/1/2004 11:41'! emphasisStringFor: emphasisCode "Answer a translated string that represents the attributes given in emphasisCode." | emphases bit | emphasisCode = 0 ifTrue: [ ^'Normal' translated ]. emphases := (IdentityDictionary new) at: 1 put: 'Bold' translated; at: 2 put: 'Italic' translated; at: 4 put: 'Underlined' translated; at: 8 put: 'Narrow' translated; at: 16 put: 'StruckOut' translated; yourself. bit := 1. ^String streamContents: [ :s | [ bit < 32 ] whileTrue: [ | code | code := emphasisCode bitAnd: bit. code isZero ifFalse: [ s nextPutAll: (emphases at: code); space ]. bit := bit bitShift: 1 ]. s position isZero ifFalse: [ s skip: -1 ]. ]! ! !AbstractLauncher methodsFor: 'private' stamp: 'mdr 4/10/2001 10:50'! numericParameterAtOneOf: alternateParameterNames ifAbsent: aBlock "Return the parameter named using one of the alternate names or an empty string" | parameterValue | parameterValue _ self parameterAtOneOf: alternateParameterNames. parameterValue isEmpty ifTrue: [^aBlock value]. ^[Number readFrom: parameterValue] ifError: aBlock ! ! !AbstractLauncher methodsFor: 'running' stamp: 'tk 10/24/2001 06:40'! startUp "A backstop for subclasses. Note that this is not a class message (most startUps are class messages)." ! ! !AbstractLauncher class methodsFor: 'private' stamp: 'sd 9/30/2003 13:55'! extractParameters ^ SmalltalkImage current extractParameters! ! !AbstractLauncher class methodsFor: 'activation'! deactivate "Unregister this launcher with the auto start class" self autoStarter removeLauncher: self! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ! !AbstractMediaEventMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:38'! initialize "initialize the state of the receiver" super initialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 2; rubberBandCells: true! ! !AbstractSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 22:34'! isStereo "Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)" ^ false ! ! !AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/16/2001 13:14'! originalSamplingRate "For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate." ^ SoundPlayer samplingRate ! ! !AbstractSound methodsFor: 'conversion' stamp: 'jm 12/16/2001 13:26'! asSampledSound "Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver." ^ SampledSound samples: self samples samplingRate: self originalSamplingRate ! ! !AbstractSound methodsFor: 'playing' stamp: 'gk 2/24/2004 22:23'! play "Play this sound to the sound output port in real time." SoundPlayer playSound: self.! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:22'! samples "Answer a monophonic sample buffer containing my samples. The left and write channels are merged." "Warning: This may require a lot of memory!!" ^ (self computeSamplesForSeconds: self duration) mergeStereo ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:24'! viewSamples "Open a WaveEditor on my samples." WaveEditor openOn: self samples. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:51'! storeAIFFOnFileNamed: fileName "Store this sound as a AIFF file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeAIFFSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:31'! storeAIFFSamplesOn: aBinaryStream "Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write AIFF file header:" aBinaryStream nextPutAll: 'FORM' asByteArray. aBinaryStream nextInt32Put: ((7 * 4) + 18) + dataByteCount. aBinaryStream nextPutAll: 'AIFF' asByteArray. aBinaryStream nextPutAll: 'COMM' asByteArray. aBinaryStream nextInt32Put: 18. aBinaryStream nextNumber: 2 put: channelCount. aBinaryStream nextInt32Put: samplesToStore. aBinaryStream nextNumber: 2 put: 16. "bits/sample" self storeExtendedFloat: self samplingRate on: aBinaryStream. aBinaryStream nextPutAll: 'SSND' asByteArray. aBinaryStream nextInt32Put: dataByteCount + 8. aBinaryStream nextInt32Put: 0. aBinaryStream nextInt32Put: 0. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." | bufSize stereoBuffer reverseBytes remaining out | self reset. bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. reverseBytes _ bigEndianFlag ~= (SmalltalkImage current isBigEndian). 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: samplesToStore during: [:bar | remaining _ samplesToStore. [remaining > 0] whileTrue: [ bar value: samplesToStore - remaining. stereoBuffer primFill: 0. "clear the buffer" self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. self isStereo ifTrue: [out _ stereoBuffer] ifFalse: [out _ stereoBuffer extractLeftChannel]. reverseBytes ifTrue: [out reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]]. remaining _ remaining - bufSize]]. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:47'! storeSunAudioOnFileNamed: fileName "Store this sound as an uncompressed Sun audio file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeSunAudioSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeSunAudioSamplesOn: aBinaryStream "Store this sound as a 16-bit Sun audio file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write Sun audio file header" channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. aBinaryStream nextPutAll: '.snd' asByteArray. aBinaryStream uint32: 24. "header size in bytes" aBinaryStream uint32: dataByteCount. aBinaryStream uint32: 3. "format: 16-bit linear" aBinaryStream uint32: self samplingRate truncated. aBinaryStream uint32: channelCount. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:03'! storeWAVOnFileNamed: fileName "Store this sound as a 16-bit Windows WAV file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeWAVSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeWAVSamplesOn: aBinaryStream "Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. samplesPerSec _ self samplingRate rounded. bytesPerSec _ samplesPerSec * channelCount * 2. "file header" aBinaryStream nextPutAll: 'RIFF' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount + 36; "total length of all chunks" nextPutAll: 'WAVE' asByteArray. "format chunk" aBinaryStream nextPutAll: 'fmt ' asByteArray; nextLittleEndianNumber: 4 put: 16; "length of this chunk" nextLittleEndianNumber: 2 put: 1; "format tag" nextLittleEndianNumber: 2 put: channelCount; nextLittleEndianNumber: 4 put: samplesPerSec; nextLittleEndianNumber: 4 put: bytesPerSec; nextLittleEndianNumber: 2 put: 4; "alignment" nextLittleEndianNumber: 2 put: 16. "bits per sample" "data chunk" aBinaryStream nextPutAll: 'data' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount. "length of this chunk" self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream. ! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! beep "Make a primitive beep." self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! playSampledSound: samples rate: rate self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! playSoundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamedOrBeep: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! randomBitsFromSoundInput: bitCount self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! sampledSoundChoices self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown "Default is to do nothing."! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! soundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem commentStamp: 'gk 2/24/2004 08:34' prior: 0! This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: SoundService default playSoundNamed: 'croak' The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the Preference class>>soundsEnabled. Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 22:27'! at: index put: aCharacter super at: index put: Character asciiValue. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:21'! byteAt: index ^ super at: index. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'! byteAt: index put: value ^ super at: index put: value. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/26/2002 20:31'! byteSize ^self size! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! do: aBlock toFieldNumber: aNumber "Considering the receiver as a holder of tab-delimited fields, evaluate aBlock on behalf of a field in this string" | start end index | start _ 1. index _ 1. [start <= self size] whileTrue: [end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. end _ end - 1. aNumber = index ifTrue: [aBlock value: (self copyFrom: start to: end). ^ self]. index _ index + 1. start _ end + 2] " 1 to: 6 do: [:aNumber | 'fred charlie elmo wimpy friml' do: [:aField | Transcript cr; show: aField] toFieldNumber: aNumber] "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! endsWithDigit "Answer whether the receiver's final character represents a digit. 3/11/96 sw" ^ self size > 0 and: [self last isDigit]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findAnySubStr: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters. delimiters is an Array of Strings (Characters are permitted also). If the receiver does not contain any of the delimiters, answer size + 1." | min ind | min _ self size + 1. delimiters do: [:delim | "May be a char, a string of length 1, or a substring" delim class == Character ifTrue: [ind _ self indexOfSubCollection: (String with: delim) startingAt: start ifAbsent: [min]] ifFalse: [ind _ self indexOfSubCollection: delim startingAt: start ifAbsent: [min]]. min _ min min: ind]. ^ min! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findBetweenSubStrs: delimiters "Answer the collection of String tokens that result from parsing self. Tokens are separated by 'delimiters', which can be a collection of Strings, or a collection of Characters. Several delimiters in a row are considered as just one separation." | tokens keyStart keyStop | tokens _ OrderedCollection new. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipAnySubStr: delimiters startingAt: keyStop. keyStop _ self findAnySubStr: delimiters startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findCloseParenthesisFor: startIndex "assume (self at: startIndex) is $(. Find the matching $), allowing parentheses to nest." " '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 " " '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 " | pos nestLevel | pos := startIndex+1. nestLevel := 1. [ pos <= self size ] whileTrue: [ (self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ]. (self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ]. nestLevel = 0 ifTrue: [ ^pos ]. pos := pos + 1. ]. ^self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findDelimiters: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1." start to: self size do: [:i | delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 10/15/2003 15:32'! findLastOccuranceOfString: subString startingAt: start "Answer the index of the last occurance of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." | last now | last _ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder. last = 0 ifTrue: [^ 0]. [last > 0] whileTrue: [ now _ last. last _ self findSubstring: subString in: self startingAt: last + subString size matchTable: CaseSensitiveOrder. ]. ^ now. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: subString "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^self findString: subString startingAt: 1.! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: subString startingAt: start "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findString: key startingAt: start caseSensitive: caseSensitive "Answer the index in this String at which the substring key first occurs, at or beyond start. The match can be case-sensitive or not. If no match is found, zero will be returned." caseSensitive ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder] ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters "Answer the collection of tokens that result from parsing self. Return strings between the delimiters. Any character in the Collection delimiters marks a border. Several delimiters in a row are considered as just one separation. Also, allow delimiters to be a single character." | tokens keyStart keyStop separators | tokens _ OrderedCollection new. separators _ delimiters class == Character ifTrue: [Array with: delimiters] ifFalse: [delimiters]. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipDelimiters: separators startingAt: keyStop. keyStop _ self findDelimiters: separators startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters includes: subString "Divide self into pieces using delimiters. Return the piece that includes subString anywhere in it. Is case sensitive (say asLowercase to everything beforehand to make insensitive)." ^ (self findTokens: delimiters) detect: [:str | (str includesSubString: subString)] ifNone: [nil]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findTokens: delimiters keep: keepers "Answer the collection of tokens that result from parsing self. The tokens are seperated by delimiters, any of a string of characters. If a delimiter is also in keepers, make a token for it. (Very useful for carriage return. A sole return ends a line, but is also saved as a token so you can see where the line breaks were.)" | tokens keyStart keyStop | tokens _ OrderedCollection new. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipDelimiters: delimiters startingAt: keyStop. keyStop to: keyStart-1 do: [:ii | (keepers includes: (self at: ii)) ifTrue: [ tokens add: (self copyFrom: ii to: ii)]]. "Make this keeper be a token" keyStop _ self findDelimiters: delimiters startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! findWordStart: key startingAt: start | ind | "HyperCard style searching. Answer the index in self of the substring key, when that key is preceeded by a separator character. Must occur at or beyond start. The match is case-insensitive. If no match is found, zero will be returned." ind _ start. [ind _ self findSubstring: key in: self startingAt: ind matchTable: CaseInsensitiveOrder. ind = 0 ifTrue: [^ 0]. "not found" ind = 1 ifTrue: [^ 1]. "First char is the start of a word" (self at: ind-1) isSeparator] whileFalse: [ind _ ind + 1]. ^ ind "is a word start"! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! includesSubString: subString ^ (self findString: subString startingAt: 1) > 0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! includesSubstring: aString caseSensitive: caseSensitive ^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 16:45'! indexOf: aCharacter aCharacter isCharacter ifFalse: [^ 0]. ^ self class indexOfAscii: aCharacter asciiValue inString: self startingAt: 1. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOf: aCharacter startingAt: start (aCharacter class == Character) ifFalse: [^ 0]. ^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOf: aCharacter startingAt: start ifAbsent: aBlock | ans | (aCharacter class == Character) ifFalse: [ ^ aBlock value ]. ans _ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start. ans = 0 ifTrue: [ ^ aBlock value ] ifFalse: [ ^ ans ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet "returns the index of the first character in the given set. Returns 0 if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet ifAbsent: aBlock "returns the index of the first character in the given set. Returns the evaluation of aBlock if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: 1 ifAbsent: aBlock! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet startingAt: start "returns the index of the first character in the given set, starting from start. Returns 0 if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: [ 0 ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock "returns the index of the first character in the given set, starting from start" | ans | ans _ String findFirstInString: self inSet: aCharacterSet byteArrayMap startingAt: start. ans = 0 ifTrue: [ ^aBlock value ] ifFalse: [ ^ans ]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfSubCollection: sub #Collectn. "Added 2000/04/08 For ANSI protocol." ^ self indexOfSubCollection: sub startingAt: 1 ifAbsent: [0]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock | index | index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder. index = 0 ifTrue: [^ exceptionBlock value]. ^ index! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! lastIndexOfPKSignature: aSignature "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" | a b c d | a _ aSignature first. b _ aSignature second. c _ aSignature third. d _ aSignature fourth. (self size - 3) to: 1 by: -1 do: [ :i | (((self at: i) = a) and: [ ((self at: i + 1) = b) and: [ ((self at: i + 2) = c) and: [ ((self at: i + 3) = d) ]]]) ifTrue: [ ^i ] ]. ^0! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 12/17/2002 16:56'! leadingCharRunLengthAt: index | leadingChar | leadingChar _ (self at: index) leadingChar. index to: self size do: [:i | (self at: i) leadingChar ~= leadingChar ifTrue: [^ i - index]. ]. ^ self size - index + 1. ! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:33'! lineCorrespondingToIndex: anIndex "Answer a string containing the line at the given character position. 1/15/96 sw: Inefficient first stab at this" | cr aChar answer | cr _ Character cr. answer _ ''. 1 to: self size do: [:i | aChar _ self at: i. aChar = cr ifTrue: [i > anIndex ifTrue: [^ answer] ifFalse: [answer _ '']] ifFalse: [answer _ answer copyWith: aChar]]. ^ answer! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'! lineCount "Answer the number of lines represented by the receiver, where every cr adds one line. 5/10/96 sw" | cr count | cr _ Character cr. count _ 1 min: self size.. 1 to: self size do: [:i | (self at: i) = cr ifTrue: [count _ count + 1]]. ^ count " 'Fred the Bear' lineCount "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:34'! lineNumber: anIndex "Answer a string containing the characters in the given line number. 5/10/96 sw" | crString pos finalPos | crString _ String with: Character cr. pos _ 0. 1 to: anIndex - 1 do: [:i | pos _ self findString: crString startingAt: pos + 1. pos = 0 ifTrue: [^ nil]]. finalPos _ self findString: crString startingAt: pos + 1. finalPos = 0 ifTrue: [finalPos _ self size + 1]. ^ self copyFrom: pos + 1 to: finalPos - 1 " 'Fred the Bear' lineNumber: 3 "! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! linesDo: aBlock "execute aBlock with each line in this string. The terminating CR's are not included in what is passed to aBlock" | start end | start _ 1. [ start <= self size ] whileTrue: [ end _ self indexOf: Character cr startingAt: start ifAbsent: [ self size + 1 ]. end _ end - 1. aBlock value: (self copyFrom: start to: end). start _ end + 2. ].! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:28'! skipAnySubStr: delimiters startingAt: start "Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1." | any this ind ii | ii _ start-1. [(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match" any _ false. delimiters do: [:delim | delim isCharacter ifTrue: [(self at: ii) == delim ifTrue: [any _ true]] ifFalse: ["a substring" delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was." [ind _ 0. this _ true. delim do: [:dd | dd == (self at: ii+ind) ifFalse: [this _ false]. ind _ ind + 1]. this ifTrue: [ii _ ii + delim size - 1. any _ true]] ifTrue: [any _ false] "if the delim is too big, it can't match"]]. any ifFalse: [^ ii]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! skipDelimiters: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1. Assumes the delimiters to be a non-empty string." start to: self size do: [:i | delimiters detect: [:delim | delim = (self at: i)] ifNone: [^ i]]. ^ self size + 1! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! startsWithDigit "Answer whether the receiver's first character represents a digit" ^ self size > 0 and: [self first isDigit]! ! !AbstractString methodsFor: 'accessing' stamp: 'yo 11/3/2004 19:24'! tabDelimitedFieldsDo: aBlock "Considering the receiver as a holder of tab-delimited fields, evaluate execute aBlock with each field in this string. The separatilng tabs are not included in what is passed to aBlock" | start end | "No senders but was useful enough in earlier work that it's retained for the moment." start _ 1. [start <= self size] whileTrue: [end _ self indexOf: Character tab startingAt: start ifAbsent: [self size + 1]. end _ end - 1. aBlock value: (self copyFrom: start to: end). start _ end + 2] " 'fred charlie elmo 2' tabDelimitedFieldsDo: [:aField | Transcript cr; show: aField] "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'! < aString "Answer whether the receiver sorts before aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:31'! <= aString "Answer whether the receiver sorts before or equal to aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! = aString "Answer whether the receiver sorts equally as aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! > aString "Answer whether the receiver sorts after aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! >= aString "Answer whether the receiver sorts after or equal to aString. The collation order is simple ascii (with case differences)." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! alike: aString "Answer some indication of how alike the receiver is to the argument, 0 is no match, twice aString size is best score. Case is ignored." | i j k minSize bonus | minSize _ (j _ self size) min: (k _ aString size). bonus _ (j - k) abs < 2 ifTrue: [ 1 ] ifFalse: [ 0 ]. i _ 1. [(i <= minSize) and: [((super at: i) bitAnd: 16rDF) = ((aString at: i) asciiValue bitAnd: 16rDF)]] whileTrue: [ i _ i + 1 ]. [(j > 0) and: [(k > 0) and: [((super at: j) bitAnd: 16rDF) = ((aString at: k) asciiValue bitAnd: 16rDF)]]] whileTrue: [ j _ j - 1. k _ k - 1. ]. ^ i - 1 + self size - j + bonus. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string. The comparison is case-sensitive." self size < prefix size ifTrue: [^ false]. ^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseSensitiveOrder) = 1 ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! caseInsensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case insensitive." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! caseSensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case sensitive." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 8/27/2002 14:15'! charactersExactlyMatching: aString "Do a character-by-character comparison between the receiver and aString. Return the index of the final character that matched exactly." | count | count _ self size min: aString size. 1 to: count do: [:i | (self at: i) = (aString at: i) ifFalse: [ ^ i - 1]]. ^ count! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! compare: aString "Answer a comparison code telling how the receiver sorts relative to aString: 1 - before 2 - equal 3 - after. The collation sequence is ascii with case differences ignored. To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! crc16 "Compute a 16 bit cyclic redundancy check." | crc | crc := 0. self do: [:c | crc := (crc bitShift: -8) bitXor: ( #( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241 16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440 16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40 16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841 16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40 16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41 16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641 16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040 16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240 16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441 16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41 16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840 16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41 16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40 16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640 16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041 16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240 16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441 16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41 16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840 16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41 16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40 16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640 16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041 16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241 16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440 16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40 16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841 16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40 16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41 16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641 16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040) at: ((crc bitXor: c asciiValue) bitAnd: 16rFF) + 1) ]. ^crc! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! endsWith: suffix "Answer whether the tail end of the receiver is the same as suffix. The comparison is case-sensitive." | extra | (extra _ self size - suffix size) < 0 ifTrue: [^ false]. ^ (self findSubstring: suffix in: self startingAt: extra + 1 matchTable: CaseSensitiveOrder) > 0 " 'Elvis' endsWith: 'vis' "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! endsWithAnyOf: aCollection aCollection do:[:suffix| (self endsWith: suffix) ifTrue:[^true]. ]. ^false! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:43'! hash "#hash is implemented, because #= is implemented" ^ self class stringHash: self initialHash: self species hash ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! hashMappedBy: map "My hash is independent of my oop." ^self hash! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! howManyMatch: string "Count the number of characters that match up in self and aString." | count shorterLength | count _ 0 . shorterLength _ ((self size ) min: (string size ) ) . (1 to: shorterLength do: [:index | (((self at: index ) = (string at: index ) ) ifTrue: [count _ (count + 1 ) . ] ). ] ). ^ count ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! match: text "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." ^ self startingAt: 1 match: text startingAt: 1 " '*' match: 'zort' true '*baz' match: 'mobaz' true '*baz' match: 'mobazo' false '*baz*' match: 'mobazo' true '*baz*' match: 'mozo' false 'foo*' match: 'foozo' true 'foo*' match: 'bozo' false 'foo*baz' match: 'foo23baz' true 'foo*baz' match: 'foobaz' true 'foo*baz' match: 'foo23bazo' false 'foo' match: 'Foo' true 'foo*baz*zort' match: 'foobazort' false 'foo*baz*zort' match: 'foobazzort' false '*foo#zort' match: 'afoo3zortthenfoo3zort' true '*foo*zort' match: 'afoodezortorfoo3zort' true "! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:32'! sameAs: aString "Answer whether the receiver sorts equal to aString. The collation sequence is ascii with case differences ignored." self subclassResponsibility. ! ! !AbstractString methodsFor: 'comparing' stamp: 'yo 11/3/2004 19:24'! startingAt: keyStart match: text startingAt: textStart "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." | anyMatch matchStart matchEnd i matchStr j ii jj | i _ keyStart. j _ textStart. "Check for any #'s" [i > self size ifTrue: [^ j > text size "Empty key matches only empty string"]. (self at: i) = $#] whileTrue: ["# consumes one char of key and one char of text" j > text size ifTrue: [^ false "no more text"]. i _ i+1. j _ j+1]. "Then check for *" (self at: i) = $* ifTrue: [i = self size ifTrue: [^ true "Terminal * matches all"]. "* means next match string can occur anywhere" anyMatch _ true. matchStart _ i + 1] ifFalse: ["Otherwise match string must occur immediately" anyMatch _ false. matchStart _ i]. "Now determine the match string" matchEnd _ self size. (ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '** not valid -- use * instead']. matchEnd _ ii-1]. (ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '*# not valid -- use #* instead']. matchEnd _ matchEnd min: ii-1]. matchStr _ self copyFrom: matchStart to: matchEnd. "Now look for the match string" [jj _ text findString: matchStr startingAt: j caseSensitive: false. anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]] whileTrue: ["Found matchStr at jj. See if the rest matches..." (self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue: [^ true "the rest matches -- success"]. "The rest did not match." anyMatch ifFalse: [^ false]. "Preceded by * -- try for a later match" j _ j+1]. ^ false "Failed to find the match string"! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! copyReplaceTokens: oldSubstring with: newSubstring "Replace all occurrences of oldSubstring that are surrounded by non-alphanumeric characters" ^ self copyReplaceAll: oldSubstring with: newSubstring asTokens: true "'File asFile Files File''s File' copyReplaceTokens: 'File' with: 'Snick'"! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! deepCopy "DeepCopy would otherwise mean make a copy of the character; since characters are unique, just return a shallowCopy." ^self shallowCopy! ! !AbstractString methodsFor: 'copying' stamp: 'yo 11/3/2004 19:24'! padded: leftOrRight to: length with: char leftOrRight = #left ifTrue: [^ (String new: (length - self size max: 0) withAll: char) , self]. leftOrRight = #right ifTrue: [^ self , (String new: (length - self size max: 0) withAll: char)].! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with a collection, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a number, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a point, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! adaptToString: rcvr andSend: selector "If I am involved in arithmetic with a string, convert us both to numbers, and return the printString of the result." ^ (rcvr asNumber perform: selector with: self asNumber) printString! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/4/2003 14:37'! asCharacter "Answer the receiver's first character, or '*' if none. Idiosyncratic, provisional." ^ self size > 0 ifTrue: [self first] ifFalse: [$*]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDate "Many allowed forms, see Date>>#readFrom:" ^ Date fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDateAndTime "Convert from UTC format" ^ DateAndTime fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 10/22/2002 17:38'! asDefaultDecodedString ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDisplayText "Answer a DisplayText whose text string is the receiver." ^DisplayText text: self asText! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asDuration "convert from [nnnd]hh:mm:ss[.nanos] format. [] implies optional elements" ^ Duration fromString: self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 2/24/2005 18:33'! asFileName "Answer a String made up from the receiver that is an acceptable file name." | string checkedString | string _ (FilePath pathName: self) asVmPathName. checkedString _ FileDirectory checkName: string fixErrors: true. ^ (FilePath pathName: checkedString isEncoded: true) asSqueakPathName. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:38'! asFourCode | result | self size = 4 ifFalse: [^self error: 'must be exactly four characters']. result _ self inject: 0 into: [:val :each | 256 * val + each asciiValue]. (result bitAnd: 16r80000000) = 0 ifFalse: [self error: 'cannot resolve fourcode']. (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. ^ result ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 23:06'! asHex | stream | stream _ WriteStream on: (String new: self size * 4). self do: [ :ch | stream nextPutAll: ch hex ]. ^stream contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asHtml "Do the basic character conversion for HTML. Leave all original return and tabs in place, so can conver back by simply removing bracked things. 4/4/96 tk" | temp | temp _ self copyReplaceAll: '&' with: '&'. HtmlEntities keysAndValuesDo: [:entity :char | char = $& ifFalse: [temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']]. temp _ temp copyReplaceAll: ' ' with: ' '. temp _ temp copyReplaceAll: ' ' with: '
'. ^ temp " 'A<&>B' asHtml "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asIRCLowercase "Answer a String made up from the receiver whose characters are all lowercase, where 'lowercase' is by IRC's definition" ^self collect: [ :c | c asIRCLowercase ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asIdentifier: shouldBeCapitalized "Return a legal identifier, with first character in upper case if shouldBeCapitalized is true, else lower case. This will always return a legal identifier, even for an empty string" | aString firstChar firstLetterPosition | aString _ self select: [:el | el isAlphaNumeric]. firstLetterPosition _ aString findFirst: [:ch | ch isLetter]. aString _ firstLetterPosition == 0 ifFalse: [aString copyFrom: firstLetterPosition to: aString size] ifTrue: ['a', aString]. firstChar _ shouldBeCapitalized ifTrue: [aString first asUppercase] ifFalse: [aString first asLowercase]. ^ firstChar asString, (aString copyFrom: 2 to: aString size) " '234Fred987' asIdentifier: false '235Fred987' asIdentifier: true '' asIdentifier: true '()87234' asIdentifier: false '())z>=PPve889 U >' asIdentifier: false "! ! !AbstractString methodsFor: 'converting' stamp: 'laza 10/1/2004 09:55'! asInteger ^self asSignedInteger ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asLegalSelector | toUse | toUse _ ''. self do: [:char | char isAlphaNumeric ifTrue: [toUse _ toUse copyWith: char]]. (self size == 0 or: [self first isLetter not]) ifTrue: [toUse _ 'v', toUse]. ^ toUse withFirstCharacterDownshifted "'234znak 43 ) 2' asLegalSelector"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asLowercase "Answer a String made up from the receiver whose characters are all lowercase." ^ self copy asString translateToLowercase! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asMorph "Answer the receiver as a StringMorph" ^ StringMorph contents: self "'bugs black blood' asMorph openInHand"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asNumber "Answer the Number created by interpreting the receiver as the string representation of a number." ^Number readFromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 16:51'! asOctetString self subclassResponsibility. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:39'! asPacked "Convert to a longinteger that describes the string" ^ self inject: 0 into: [ :pack :next | pack _ pack * 256 + next asInteger ].! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asParagraph "Answer a Paragraph whose text string is the receiver." ^Paragraph withText: self asText! ! !AbstractString methodsFor: 'converting' stamp: 'laza 10/1/2004 09:54'! asSignedInteger "Returns the first signed integer it can find or nil." | start stream | start := self findFirst: [:char | char isDigit]. start isZero ifTrue: [^nil]. stream := (ReadStream on: self) position: start. stream back = $- ifTrue: [stream back]. ^Integer readFrom: stream! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asSmalltalkComment "return this string, munged so that it can be treated as a comment in Smalltalk code. Quote marks are added to the beginning and end of the string, and whenever a solitary quote mark appears within the string, it is doubled" ^String streamContents: [ :str | | quoteCount first | str nextPut: $". quoteCount := 0. first := true. self do: [ :char | char = $" ifTrue: [ first ifFalse: [ str nextPut: char. quoteCount := quoteCount + 1 ] ] ifFalse: [ quoteCount odd ifTrue: [ "add a quote to even the number of quotes in a row" str nextPut: $" ]. quoteCount := 0. str nextPut: char ]. first := false ]. quoteCount odd ifTrue: [ "check at the end" str nextPut: $". ]. str nextPut: $". ]. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 12/19/2003 21:16'! asSqueakPathName ^ self. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asString "Answer this string." ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asStringOrText "Answer this string." ^ self ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:53'! asSymbol "Answer the unique Symbol whose characters are the characters of the string." ^ self class correspondingSymbolClass intern: self. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asText "Answer a Text whose string is the receiver." ^Text fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asTime "Many allowed forms, see Time>>readFrom:" ^ Time fromString: self.! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asTimeStamp "Convert from obsolete TimeStamp format" ^ TimeStamp fromString: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/26/2002 20:31'! asUnHtml "Strip out all Html stuff (commands in angle brackets <>) and convert the characters &<> back to their real value. Leave actual cr and tab as they were in text." | in out char rest did | in _ ReadStream on: self. out _ WriteStream on: (String new: self size). [in atEnd] whileFalse: [in peek = $< ifTrue: [in unCommand] "Absorb <...><...>" ifFalse: [(char _ in next) = $& ifTrue: [rest _ in upTo: $;. did _ out position. rest = 'lt' ifTrue: [out nextPut: $<]. rest = 'gt' ifTrue: [out nextPut: $>]. rest = 'amp' ifTrue: [out nextPut: $&]. did = out position ifTrue: [ self error: 'new HTML char encoding'. "Please add it to this code"]] ifFalse: [out nextPut: char]]. ]. ^ out contents! ! !AbstractString methodsFor: 'converting' stamp: 'laza 10/1/2004 10:02'! asUnsignedInteger "Returns the first integer it can find or nil." | start stream | start := self findFirst: [:char | char isDigit]. start isZero ifTrue: [^nil]. stream := (ReadStream on: self) position: start - 1. ^Integer readFrom: stream! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUppercase "Answer a String made up from the receiver whose characters are all uppercase." ^self copy asString translateToUppercase! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUrl "convert to a Url" "'http://www.cc.gatech.edu/' asUrl" "msw://chaos.resnet.gatech.edu:9000/' asUrl" ^Url absoluteFromText: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! asUrlRelativeTo: aUrl ^aUrl newFromRelativeText: self! ! !AbstractString methodsFor: 'converting' stamp: 'yo 2/24/2005 18:33'! asVmPathName ^ (FilePath pathName: self) asVmPathName. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! askIfAddStyle: priorMethod req: requestor ^ self "we are a string with no text style"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! capitalized "Return a copy with the first letter capitalized" | cap | self isEmpty ifTrue: [ ^self copy ]. cap _ self copy. cap at: 1 put: (cap at: 1) asUppercase. ^ cap! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! compressWithTable: tokens "Return a string with all substrings that occur in tokens replaced by a character with ascii code = 127 + token index. This will work best if tokens are sorted by size. Assumes this string contains no characters > 127, or that they are intentionally there and will not interfere with this process." | str null finalSize start result ri c ts | null _ Character value: 0. str _ self copyFrom: 1 to: self size. "Working string will get altered" finalSize _ str size. tokens doWithIndex: [:token :tIndex | start _ 1. [(start _ str findString: token startingAt: start) > 0] whileTrue: [ts _ token size. ((start + ts) <= str size and: [(str at: start + ts) = $ and: [tIndex*2 <= 128]]) ifTrue: [ts _ token size + 1. "include training blank" str at: start put: (Character value: tIndex*2 + 127)] ifFalse: [str at: start put: (Character value: tIndex + 127)]. str at: start put: (Character value: tIndex + 127). 1 to: ts-1 do: [:i | str at: start+i put: null]. finalSize _ finalSize - (ts - 1). start _ start + ts]]. result _ String new: finalSize. ri _ 0. 1 to: str size do: [:i | (c _ str at: i) = null ifFalse: [result at: (ri _ ri+1) put: c]]. ^ result! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! contractTo: smallSize "return myself or a copy shortened by ellipsis to smallSize" | leftSize | self size <= smallSize ifTrue: [^ self]. "short enough" smallSize < 5 ifTrue: [^ self copyFrom: 1 to: smallSize]. "First N characters" leftSize _ smallSize-2//2. ^ self copyReplaceFrom: leftSize+1 "First N/2 ... last N/2" to: self size - (smallSize - leftSize - 3) with: '...' " 'A clear but rather long-winded summary' contractTo: 18 "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 7/8/2004 12:02'! convertFromWithConverter: converter | readStream writeStream c | readStream _ self readStream. writeStream _ String new writeStream. converter ifNil: [^ self]. [readStream atEnd] whileFalse: [ c _ converter nextFromStream: readStream. c ifNotNil: [writeStream nextPut: c] ifNil: [^ writeStream contents] ]. ^ writeStream contents ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 7/8/2004 12:01'! convertToWithConverter: converter | readStream writeStream | readStream _ self readStream. writeStream _ String new writeStream. converter ifNil: [^ self]. [readStream atEnd] whileFalse: [ converter nextPut: readStream next toStream: writeStream ]. converter emitSequenceToResetStateIfNeededOn: writeStream. ^ writeStream contents. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainst: wordList "Correct the receiver: assume it is a misspelled word and return the (maximum of five) nearest words in the wordList. Depends on the scoring scheme of alike:" | results | results _ self correctAgainst: wordList continuedFrom: nil. results _ self correctAgainst: nil continuedFrom: results. ^ results! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainst: wordList continuedFrom: oldCollection "Like correctAgainst:. Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList." ^ wordList isNil ifTrue: [ self correctAgainstEnumerator: nil continuedFrom: oldCollection ] ifFalse: [ self correctAgainstEnumerator: [ :action | wordList do: action without: nil] continuedFrom: oldCollection ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! correctAgainstDictionary: wordDict continuedFrom: oldCollection "Like correctAgainst:continuedFrom:. Use when you want to correct against a dictionary." ^ wordDict isNil ifTrue: [ self correctAgainstEnumerator: nil continuedFrom: oldCollection ] ifFalse: [ self correctAgainstEnumerator: [ :action | wordDict keysDo: action ] continuedFrom: oldCollection ]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/2/2004 17:31'! encodeForHTTP "change dangerous characters to their %XX form, for use in HTTP transactions" | encodedStream | encodedStream _ WriteStream on: (String new). self do: [ :c | c isSafeForHTTP ifTrue: [ encodedStream nextPut: c ] ifFalse: [ encodedStream nextPut: $%. encodedStream nextPut: (c asciiValue // 16) asHexDigit. encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. ] ]. ^encodedStream contents. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 7/5/2004 16:48'! findSelector "Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it." | sel possibleParens level n | sel _ self withBlanksTrimmed. (sel includes: $:) ifTrue: [sel _ sel copyReplaceAll: ':' with: ': '. "for the style (aa max:bb) with no space" possibleParens _ sel findTokens: Character separators. sel _ self class streamContents: [:s | level _ 0. possibleParens do: [:token | (level = 0 and: [token endsWith: ':']) ifTrue: [s nextPutAll: token] ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n]. (n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]]. sel isEmpty ifTrue: [^ nil]. sel isOctetString ifTrue: [sel _ sel asOctetString]. Symbol hasInterned: sel ifTrue: [:aSymbol | ^ aSymbol]. ^ nil! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! initialIntegerOrNil "Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit" | firstNonDigit | (self size == 0 or: [self first isDigit not]) ifTrue: [^ nil]. firstNonDigit _ (self findFirst: [:m | m isDigit not]). firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1]. ^ (self copyFrom: 1 to: (firstNonDigit - 1)) asNumber " '234Whoopie' initialIntegerOrNil 'wimpy' initialIntegerOrNil '234' initialIntegerOrNil '2N' initialIntegerOrNil '2' initialIntegerOrNil ' 89Ten ' initialIntegerOrNil '78 92' initialIntegerOrNil " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! keywords "Answer an array of the keywords that compose the receiver." | kwd char keywords | keywords _ Array streamContents: [:kwds | kwd _ WriteStream on: (String new: 16). 1 to: self size do: [:i | kwd nextPut: (char _ self at: i). char = $: ifTrue: [kwds nextPut: kwd contents. kwd reset]]. kwd isEmpty ifFalse: [kwds nextPut: kwd contents]]. (keywords size >= 1 and: [(keywords at: 1) = ':']) ifTrue: ["Has an initial keyword, as in #:if:then:else:" keywords _ keywords allButFirst]. (keywords size >= 2 and: [(keywords at: keywords size - 1) = ':']) ifTrue: ["Has a final keyword, as in #nextPut::andCR" keywords _ keywords copyReplaceFrom: keywords size - 1 to: keywords size with: {':' , keywords last}]. ^ keywords! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! numericSuffix ^ self stemAndNumericSuffix last " 'abc98' numericSuffix '98abc' numericSuffix "! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! onlyLetters "answer the receiver with only letters" ^ self select:[:each | each isLetter]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! openAsMorph "Open the receiver as a morph" ^ self asMorph openInHand ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! romanNumber | value v1 v2 | value _ v1 _ v2 _ 0. self reverseDo: [:each | v1 _ #(1 5 10 50 100 500 1000) at: ('IVXLCDM' indexOf: each). v1 >= v2 ifTrue: [value _ value + v1] ifFalse: [value _ value - v1]. v2 _ v1]. ^ value! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! sansPeriodSuffix "Return a copy of the receiver up to, but not including, the first period. If the receiver's *first* character is a period, then just return the entire receiver. " | likely | likely _ self copyUpTo: $.. ^ likely size == 0 ifTrue: [self] ifFalse: [likely]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:13'! splitInteger "Answer an array that is a splitting of self into a string and an integer. '43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90) BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, ( )." | pos | (pos _ self findFirst: [:d | d isDigit not]) = 0 ifTrue: [^ Array with: '' with: self asNumber]. self first isDigit ifTrue: [ ^ Array with: (self copyFrom: 1 to: pos - 1) asNumber with: (self copyFrom: pos to: self size)]. (pos _ self findFirst: [:d | d isDigit]) = 0 ifTrue: [^ Array with: self with: 0]. ^ Array with: (self copyFrom: 1 to: pos - 1) with: (self copyFrom: pos to: self size) asNumber! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! stemAndNumericSuffix "Parse the receiver into a string-valued stem and a numeric-valued suffix. 6/7/96 sw" | stem suffix position | stem _ self. suffix _ 0. position _ 1. [stem endsWithDigit and: [stem size > 1]] whileTrue: [suffix _ stem last digitValue * position + suffix. position _ position * 10. stem _ stem copyFrom: 1 to: stem size - 1]. ^ Array with: stem with: suffix "'Fred2305' stemAndNumericSuffix"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! subStrings "Answer an array of the substrings that compose the receiver." #Collectn. "Added 2000/04/08 For ANSI protocol." ^ self substrings! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! subStrings: separators "Answer an array containing the substrings in the receiver separated by the elements of separators." | char result sourceStream subString | #Collectn. "Changed 2000/04/08 For ANSI protocol." (separators allSatisfy: [:element | element isKindOf: Character]) ifFalse: [^ self error: 'separators must be Characters.']. sourceStream := ReadStream on: self. result := OrderedCollection new. subString := String new. [sourceStream atEnd] whileFalse: [char := sourceStream next. (separators includes: char) ifTrue: [subString notEmpty ifTrue: [result add: subString copy. subString := String new]] ifFalse: [subString := subString , (String with: char)]]. subString notEmpty ifTrue: [result add: subString copy]. ^ result asArray! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! substrings "Answer an array of the substrings that compose the receiver." | result end beginning | result _ WriteStream on: (Array new: 10). end _ 0. "find one substring each time through this loop" [ "find the beginning of the next substring" beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ]. beginning ~~ nil ] whileTrue: [ "find the end" end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ]. end _ end - 1. result nextPut: (self copyFrom: beginning to: end). ]. ^result contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! surroundedBySingleQuotes "Answer the receiver with leading and trailing quotes. " ^ $' asString, self, $' asString! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:14'! translateFrom: start to: stop table: table "translate the characters in the string by the given table, in place" self class translate: self from: start to: stop table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateToLowercase "Translate all characters to lowercase, in place" self translateWith: LowercasingTable! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! translateToUppercase "Translate all characters to lowercase, in place" self translateWith: UppercasingTable! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:13'! translateWith: table "translate the characters in the string by the given table, in place" ^ self translateFrom: 1 to: self size table: table! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! truncateTo: smallSize "return myself or a copy shortened to smallSize. 1/18/96 sw" ^ self size <= smallSize ifTrue: [self] ifFalse: [self copyFrom: 1 to: smallSize]! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! truncateWithElipsisTo: maxLength "Return myself or a copy suitably shortened but with elipsis added" ^ self size <= maxLength ifTrue: [self] ifFalse: [(self copyFrom: 1 to: (maxLength - 3)), '...'] "'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 11:20'! unparenthetically "If the receiver starts with (..( and ends with matching )..), strip them" | curr | curr _ self. [((curr first = $() and: [curr last = $)])] whileTrue: [curr _ curr copyFrom: 2 to: (curr size - 1)]. ^ curr " '((fred the bear))' unparenthetically " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! unzipped | magic1 magic2 | magic1 _ (self at: 1) asInteger. magic2 _ (self at: 2) asInteger. (magic1 = 16r1F and:[magic2 = 16r8B]) ifFalse:[^self]. ^(GZipReadStream on: self) upToEnd! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withBlanksCondensed "Return a copy of the receiver with leading/trailing blanks removed and consecutive white spaces condensed." | trimmed lastBlank | trimmed _ self withBlanksTrimmed. ^String streamContents: [:stream | lastBlank _ false. trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c]. lastBlank _ c isSeparator]]. " ' abc d ' withBlanksCondensed" ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 7/5/2004 16:43'! withBlanksTrimmed "Return a copy of the receiver from which leading and trailing blanks have been trimmed." | first result | first _ self findFirst: [:c | c isSeparator not]. first = 0 ifTrue: [^ '']. "no non-separator character" result _ self copyFrom: first to: (self findLast: [:c | c isSeparator not]). result isOctetString ifTrue: [^ result asOctetString] ifFalse: [^ result]. " ' abc d ' withBlanksTrimmed" ! ! !AbstractString methodsFor: 'converting' stamp: 'md 9/19/2004 15:19'! withFirstCharacterDownshifted "Return a copy with the first letter downShifted" | answer | self ifEmpty: [^ self copy]. answer _ self copy. answer at: 1 put: (answer at: 1) asLowercase. ^ answer. ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withNoLineLongerThan: aNumber "Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number" | listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition | aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow']. listOfLines _ OrderedCollection new. currentLast _ 0. [currentLast < self size] whileTrue: [currentStart _ currentLast + 1. putativeLast _ (currentStart + aNumber - 1) min: self size. putativeLine _ self copyFrom: currentStart to: putativeLast. (crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue: [putativeLast _ currentStart + crPosition - 1. putativeLine _ self copyFrom: currentStart to: putativeLast]. currentLast _ putativeLast == self size ifTrue: [putativeLast] ifFalse: [currentStart + putativeLine lastSpacePosition - 1]. currentLast <= currentStart ifTrue: ["line has NO spaces; baleout!!" currentLast _ putativeLast]. listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed]. listOfLines size > 0 ifFalse: [^ '']. resultString _ listOfLines first. 2 to: listOfLines size do: [:i | resultString _ resultString, String cr, (listOfLines at: i)]. ^ resultString "#(5 7 20) collect: [:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! ! !AbstractString methodsFor: 'converting' stamp: 'tak 4/25/2004 12:57'! withSeparatorsCompacted "replace each sequences of whitespace by a single space character" "' test ' withSeparatorsCompacted = ' test '" "' test test' withSeparatorsCompacted = ' test test'" "'test test ' withSeparatorsCompacted = 'test test '" | out in next isSeparator | self isEmpty ifTrue: [^ self]. out _ WriteStream on: (String new: self size). in _ self readStream. isSeparator _ [:char | char asciiValue < 256 and: [CSSeparators includes: char]]. [in atEnd] whileFalse: [ next _ in next. (isSeparator value: next) ifTrue: [ out nextPut: $ . [in atEnd or: [next _ in next. (isSeparator value: next) ifTrue: [false] ifFalse: [out nextPut: next. true]]] whileFalse] ifFalse: [out nextPut: next]]. ^ out contents! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'! withoutLeadingDigits "Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstNonDigit | firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~= $ ]]). ^ firstNonDigit > 0 ifTrue: [self copyFrom: firstNonDigit to: self size] ifFalse: [''] " '234Whoopie' withoutLeadingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 11/3/2004 19:24'! withoutTrailingBlanks "Return a copy of the receiver from which trailing blanks have been trimmed." | last | last _ self findLast: [:c | c isSeparator not]. last = 0 ifTrue: [^ '']. "no non-separator character" ^ self copyFrom: 1 to: last " ' abc d ' withoutTrailingBlanks" ! ! !AbstractString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:06'! withoutTrailingDigits "Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstDigit | firstDigit _ (self findFirst: [:m | m isDigit or: [m = $ ]]). ^ firstDigit > 0 ifTrue: [self copyFrom: 1 to: firstDigit-1] ifFalse: [self] " 'Whoopie234' withoutTrailingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayAt: aPoint "Display the receiver as a DisplayText at aPoint on the display screen." self displayOn: Display at: aPoint! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium "Display the receiver on the given DisplayMedium. 5/16/96 sw" self displayOn: aDisplayMedium at: 0 @ 0! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium at: aPoint "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, using black-colored text." self displayOn: aDisplayMedium at: aPoint textColor: Color black! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayOn: aDisplayMedium at: aPoint textColor: aColor "Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color" (self asDisplayText foregroundColor: (aColor ifNil: [Color black]) backgroundColor: Color white) displayOn: aDisplayMedium at: aPoint! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! displayProgressAt: aPoint from: minVal to: maxVal during: workBlock "Display this string as a caption over a progress bar while workBlock is evaluated. EXAMPLE (Select next 6 lines and Do It) 'Now here''s some Real Progress' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]. HOW IT WORKS (Try this in any other language :-) Since your code (the last 2 lines in the above example) is in a block, this method gets control to display its heading before, and clean up the screen after, its execution. The key, though, is that the block is supplied with an argument, named 'bar' in the example, which will update the bar image every it is sent the message value: x, where x is in the from:to: range. " ^ProgressInitiationException display: self at: aPoint from: minVal to: maxVal during: workBlock! ! !AbstractString methodsFor: 'displaying' stamp: 'yo 11/3/2004 19:24'! newTileMorphRepresentative ^ TileMorph new setLiteral: self! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! basicType "Answer a symbol representing the inherent type of the receiver" "Number String Boolean player collection sound color etc" ^ #String! ! !AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:57'! encodeDoublingQuoteOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream print: $'. 1 to: self size do: [:i | aStream print: (x _ self at: i). x = $' ifTrue: [aStream print: x]]. aStream print: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! isLiteral ^true! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! printOn: aStream "Print inside string quotes, doubling inbedded quotes." self storeOn: aStream! ! !AbstractString methodsFor: 'printing' stamp: 'yo 8/26/2002 22:58'! storeOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream nextPut: $'. 1 to: self size do: [:i | aStream nextPut: (x _ self at: i). x = $' ifTrue: [aStream nextPut: x]]. aStream nextPut: $'! ! !AbstractString methodsFor: 'printing' stamp: 'yo 11/3/2004 19:24'! stringRepresentation "Answer a string that represents the receiver. For most objects this is simply its printString, but for strings themselves, it's themselves, to avoid the superfluous extra pair of quotes. 6/12/96 sw" ^ self ! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! correctAgainstEnumerator: wordBlock continuedFrom: oldCollection "The guts of correction, instead of a wordList, there is a block that should take another block and enumerate over some list with it." | choices scoreMin results score maxChoices | scoreMin _ self size // 2 min: 3. maxChoices _ 10. oldCollection isNil ifTrue: [ choices _ SortedCollection sortBlock: [ :x :y | x value > y value ] ] ifFalse: [ choices _ oldCollection ]. wordBlock isNil ifTrue: [ results _ OrderedCollection new. 1 to: (maxChoices min: choices size) do: [ :i | results add: (choices at: i) key ] ] ifFalse: [ wordBlock value: [ :word | (score _ self alike: word) >= scoreMin ifTrue: [ choices add: (Association key: word value: score). (choices size >= maxChoices) ifTrue: [ scoreMin _ (choices at: maxChoices) value] ] ]. results _ choices ]. ^ results! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! evaluateExpression: aString parameters: aCollection "private - evaluate the expression aString with aCollection as the parameters and answer the evaluation result as an string" | index | index := ('0' , aString) asNumber. index isZero ifTrue: [^ '[invalid subscript: {1}]' format: {aString}]. index > aCollection size ifTrue: [^ '[subscript is out of bounds: {1}]' format: {aString}]. ^ (aCollection at: index) asString! ! !AbstractString methodsFor: 'private' stamp: 'yo 11/3/2004 19:24'! getEnclosedExpressionFrom: aStream "private - get the expression enclosed between '{' and '}' and remove all the characters from the stream" | result currentChar | result := String new writeStream. [aStream atEnd or: [(currentChar := aStream next) == $}]] whileFalse: [result nextPut: currentChar]. ^ result contents withBlanksTrimmed! ! !AbstractString methodsFor: 'private' stamp: 'yo 8/26/2002 22:53'! replaceFrom: start to: stop with: replacement startingAt: repStart "Primitive. This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the collection, replacement. Answer the receiver. Range checks are performed in the primitive only. Optional. See Object documentation whatIsAPrimitive." super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !AbstractString methodsFor: 'private' stamp: 'yo 8/28/2002 15:22'! stringhash ^ self hash. ! ! !AbstractString methodsFor: 'system primitives' stamp: 'yo 11/5/2002 15:32'! compare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." self subclassResponsibility. ! ! !AbstractString methodsFor: 'system primitives' stamp: 'bf 8/31/2004 13:50'! findSubstring: key in: body startingAt: start matchTable: matchTable ^self subclassResponsibility! ! !AbstractString methodsFor: 'system primitives' stamp: 'yo 11/3/2004 19:24'! numArgs "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction." | firstChar numColons excess start ix | self size = 0 ifTrue: [^ -1]. firstChar _ self at: 1. (firstChar isLetter or: [firstChar = $:]) ifTrue: ["Fast reject if any chars are non-alphanumeric" (self findSubstring: '~' in: self startingAt: 1 matchTable: Tokenish) > 0 ifTrue: [^ -1]. "Fast colon count" numColons _ 0. start _ 1. [(ix _ self findSubstring: ':' in: self startingAt: start matchTable: CaseSensitiveOrder) > 0] whileTrue: [numColons _ numColons + 1. start _ ix + 1]. numColons = 0 ifTrue: [^ 0]. firstChar = $: ifTrue: [excess _ 2 "Has an initial keyword, as #:if:then:else:"] ifFalse: [excess _ 0]. self last = $: ifTrue: [^ numColons - excess] ifFalse: [^ numColons - excess - 1 "Has a final keywords as #nextPut::andCR"]]. firstChar isSpecial ifTrue: [self size = 1 ifTrue: [^ 1]. 2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]]. ^ 1]. ^ -1.! ! !AbstractString methodsFor: 'Celeste' stamp: 'yo 11/3/2004 19:24'! withCRs "Return a copy of the receiver in which backslash (\) characters have been replaced with carriage returns." ^ self collect: [ :c | c = $\ ifTrue: [ Character cr ] ifFalse: [ c ]].! ! !AbstractString methodsFor: 'internet' stamp: 'yo 12/28/2003 01:17'! decodeMimeHeader "See RFC 2047, MIME Part Three: Message Header Extension for Non-ASCII Text. Text containing non-ASCII characters is encoded by the sequence =?character-set?encoding?encoded-text?= Encoding is Q (quoted printable) or B (Base64), handled by Base64MimeConverter / RFC2047MimeConverter. Thanks to Yokokawa-san, it works in m17n package. Try the following: '=?ISO-2022-JP?B?U1dJS0lQT1AvGyRCPUJDKyVpJXMlQRsoQi8=?= =?ISO-2022-JP?B?GyRCJVElRiUjJSobKEIoUGF0aW8p?=' decodeMimeHeader. " | input output temp charset decoder encodedStream encoding pos | input _ ReadStream on: self. output _ WriteStream on: String new. [output nextPutAll: (input upTo: $=). "ASCII Text" input atEnd] whileFalse: [(temp _ input next) = $? ifTrue: [charset _ input upTo: $?. encoding _ (input upTo: $?) asUppercase. temp _ input upTo: $?. input next. "Skip final =" (charset isNil or: [charset size = 0]) ifTrue: [charset _ 'LATIN-1']. encodedStream _ MultiByteBinaryOrTextStream on: String new encoding: charset. decoder _ encoding = 'B' ifTrue: [Base64MimeConverter new] ifFalse: [RFC2047MimeConverter new]. decoder mimeStream: (ReadStream on: temp); dataStream: encodedStream; mimeDecode. output nextPutAll: encodedStream reset contents. pos _ input position. input skipSeparators. "Delete spaces if followed by =" input peek = $= ifFalse: [input position: pos]] ifFalse: [output nextPut: $=; nextPut: temp]]. ^ output contents! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! decodeQuotedPrintable "Assume receiver is in MIME 'quoted-printable' encoding, and decode it." ^QuotedPrintableMimeConverter mimeDecode: self as: self class! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! isoToSqueak ^ self collect: [:each | each isoToSqueak]! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! isoToUtf8 "Convert ISO 8559-1 to UTF-8" | s v | s _ WriteStream on: (String new: self size). self do: [:c | v _ c asciiValue. (v > 128) ifFalse: [s nextPut: c] ifTrue: [ s nextPut: (192+(v >> 6)) asCharacter. s nextPut: (128+(v bitAnd: 63)) asCharacter]]. ^s contents. ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! squeakToIso ^self collect: [:c | c squeakToIso ]! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! unescapePercents "change each %XY substring to the character with ASCII value XY in hex. This is the opposite of #encodeForHTTP" | ans c asciiVal pos oldPos specialChars | ans _ WriteStream on: String new. oldPos _ 1. specialChars _ '+%' asCharacterSet. [pos _ self indexOfAnyOf: specialChars startingAt: oldPos. pos > 0] whileTrue: [ ans nextPutAll: (self copyFrom: oldPos to: pos - 1). c _ self at: pos. c = $+ ifTrue: [ans nextPut: $ ] ifFalse: [ (c = $% and: [pos + 2 <= self size]) ifTrue: [ asciiVal _ (self at: pos+1) asUppercase digitValue * 16 + (self at: pos+2) asUppercase digitValue. pos _ pos + 2. asciiVal > 255 ifTrue: [^self]. "not really an escaped string" ans nextPut: (Character value: asciiVal)] ifFalse: [ans nextPut: c]]. oldPos _ pos+1]. ans nextPutAll: (self copyFrom: oldPos to: self size). ^ ans contents! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! utf8ToIso "Only UTF-8 characters that maps to 8-bit ISO-8559-1 values are converted. Others raises an error" | s i c v c2 v2 | s _ WriteStream on: (String new: self size). i _ 1. [i <= self size] whileTrue: [ c _ self at: i. i_i+1. v _ c asciiValue. (v > 128) ifFalse: [ s nextPut: c ] ifTrue: [((v bitAnd: 252) == 192) ifFalse: [self error: 'illegal UTF-8 ISO character'] ifTrue: [ (i > self size) ifTrue: [ self error: 'illegal end-of-string, expected 2nd byte of UTF-8']. c2 _ self at: i. i_i+1. v2 _ c2 asciiValue. ((v2 bitAnd: 192) = 128) ifFalse: [self error: 'illegal 2nd UTF-8 char']. s nextPut: ((v2 bitAnd: 63) bitOr: ((v << 6) bitAnd: 192)) asCharacter]]]. ^s contents. ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withInternetLineEndings "change line endings from CR's to CRLF's. This is probably in prepration for sending a string over the Internet" | cr lf | cr _ Character cr. lf _ Character linefeed. ^self class streamContents: [ :stream | self do: [ :c | stream nextPut: c. c = cr ifTrue:[ stream nextPut: lf ]. ] ].! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withSqueakLineEndings "assume the string is textual, and that CR, LF, and CRLF are all valid line endings. Replace each occurence with a single CR" | cr lf input c crlf inPos outPos outString lineEndPos newOutPos | cr _ Character cr. lf _ Character linefeed. crlf _ CharacterSet new. crlf add: cr; add: lf. inPos _ 1. outPos _ 1. outString _ String new: self size. [ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0]. lineEndPos ~= 0 ] whileTrue: [ newOutPos _ outPos + (lineEndPos - inPos + 1). outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos. outString at: newOutPos-1 put: cr. outPos _ newOutPos. ((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [ "CRLF ending" inPos _ lineEndPos + 2 ] ifFalse: [ "CR or LF ending" inPos _ lineEndPos + 1 ]. ]. "no more line endings. copy the rest" newOutPos _ outPos + (self size - inPos + 1). outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos. ^outString copyFrom: 1 to: newOutPos-1 ! ! !AbstractString methodsFor: 'internet' stamp: 'yo 11/3/2004 19:24'! withoutQuoting "remove the initial and final quote marks, if present" "'''h''' withoutQuoting" | quote | self size < 2 ifTrue: [ ^self ]. quote _ self first. (quote = $' or: [ quote = $" ]) ifTrue: [ ^self copyFrom: 2 to: self size - 1 ] ifFalse: [ ^self ].! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! hasContentsInExplorer ^false! ! !AbstractString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:09'! includesUnifiedCharacter self subclassResponsibility. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isAllDigits "whether the receiver is composed entirely of digits" self do: [:c | c isDigit ifFalse: [^ false]]. ^ true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isAllSeparators "whether the receiver is composed entirely of separators" self do: [ :c | c isSeparator ifFalse: [ ^false ] ]. ^true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 8/4/2003 12:26'! isAsciiString | c | c _ self detect: [:each | each asciiValue > 127] ifNone: [nil]. ^ c isNil. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 8/28/2002 15:19'! isOctetString self subclassResponsibility. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! isString ^ true! ! !AbstractString methodsFor: 'testing' stamp: 'yo 12/29/2002 10:30'! isUnicodeString ^ false. ! ! !AbstractString methodsFor: 'testing' stamp: 'yo 11/3/2004 19:24'! lastSpacePosition "Answer the character position of the final space or other separator character in the receiver, and 0 if none" self size to: 1 by: -1 do: [:i | ((self at: i) isSeparator) ifTrue: [^ i]]. ^ 0 " 'fred the bear' lastSpacePosition 'ziggie' lastSpacePosition 'elvis ' lastSpacePosition 'wimpy ' lastSpacePosition '' lastSpacePosition "! ! !AbstractString methodsFor: 'paragraph support' stamp: 'yo 8/26/2002 22:19'! indentationIfBlank: aBlock "Answer the number of leading tabs in the receiver. If there are no visible characters, pass the number of tabs to aBlock and return its value." | reader leadingTabs lastSeparator cr tab ch | cr _ Character cr. tab _ Character tab. reader _ ReadStream on: self. leadingTabs _ 0. [reader atEnd not and: [(ch _ reader next) = tab]] whileTrue: [leadingTabs _ leadingTabs + 1]. lastSeparator _ leadingTabs + 1. [reader atEnd not and: [ch isSeparator and: [ch ~= cr]]] whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next]. lastSeparator = self size | (ch = cr) ifTrue: [^aBlock value: leadingTabs]. ^ leadingTabs. ! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! * arg ^ arg adaptToString: self andSend: #*! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! + arg ^ arg adaptToString: self andSend: #+! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! - arg ^ arg adaptToString: self andSend: #-! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! / arg ^ arg adaptToString: self andSend: #/! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! // arg ^ arg adaptToString: self andSend: #//! ! !AbstractString methodsFor: 'arithmetic' stamp: 'yo 11/3/2004 19:24'! \\ arg ^ arg adaptToString: self andSend: #\\! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'! byteEncode:aStream ^aStream writeString: self. ! ! !AbstractString methodsFor: 'filter streaming' stamp: 'yo 8/26/2002 22:31'! putOn:aStream ^aStream nextPutAll: self. ! ! !AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'! getInteger32: location | integer | "^IntegerPokerPlugin doPrimitive: #getInteger" "the following is about 7x faster than interpreting the plugin if not compiled" integer := ((self byteAt: location) bitShift: 24) + ((self byteAt: location+1) bitShift: 16) + ((self byteAt: location+2) bitShift: 8) + (self byteAt: location+3). integer > 1073741824 ifTrue: [ ^1073741824 - integer ]. ^integer ! ! !AbstractString methodsFor: 'encoding' stamp: 'yo 11/3/2004 19:24'! putInteger32: anInteger at: location | integer | "IntegerPokerPlugin doPrimitive: #putInteger" "the following is close to 20x faster than the above if the primitive is not compiled" "PUTCOUNTER _ PUTCOUNTER + 1." integer _ anInteger. integer < 0 ifTrue: [integer := 1073741824 - integer. ]. self byteAt: location+3 put: (integer \\ 256). self byteAt: location+2 put: (integer bitShift: -8) \\ 256. self byteAt: location+1 put: (integer bitShift: -16) \\ 256. self byteAt: location put: (integer bitShift: -24) \\ 256. "Smalltalk at: #PUTCOUNTER put: 0"! ! !AbstractString methodsFor: 'user interface' stamp: 'yo 8/26/2002 22:20'! asExplorerString ^ self asString! ! !AbstractString methodsFor: 'user interface' stamp: 'yo 11/3/2004 19:24'! openInWorkspaceWithTitle: aTitle "Open up a workspace with the receiver as its contents, with the given title" (Workspace new contents: self) openLabel: aTitle! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31'! sunitAsSymbol ^self asSymbol! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31'! sunitMatch: aString ^self match: aString! ! !AbstractString methodsFor: 'Camp Smalltalk' stamp: 'yo 8/26/2002 20:31'! sunitSubStrings ^self substrings! ! !AbstractString methodsFor: '*packageinfo-base' stamp: 'nk 8/30/2004 09:02'! escapeEntities ^ self species streamContents: [:s | self do: [:c | s nextPutAll: c escapeEntities]] ! ! !AbstractString methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:42'! translated "answer the receiver translated to the default language" ^ NaturalLanguageTranslator current translate: self! ! !AbstractString methodsFor: 'translating' stamp: 'dgd 8/27/2004 18:43'! translatedIfCorresponds "answer the receiver translated to the default language only if the receiver begins and ends with an underscore (_)" ^ ('_*_' match: self) ifTrue: [(self copyFrom: 2 to: self size - 1) translated] ifFalse: [self]! ! !AbstractString methodsFor: 'translating' stamp: 'dgd 8/24/2004 19:38'! translatedTo: localeID "answer the receiver translated to the given locale id" ^ localeID translator translate: self! ! !AbstractString methodsFor: 'formatting' stamp: 'yo 11/3/2004 19:24'! format: aCollection "format the receiver with aCollection simplest example: 'foo {1} bar' format: {Date today}. complete example: '\{ \} \\ foo {1} bar {2}' format: {12. 'string'}. " | result stream | result := String new writeStream. stream := self readStream. [stream atEnd] whileFalse: [| currentChar | currentChar := stream next. currentChar == ${ ifTrue: [| expression | expression := self getEnclosedExpressionFrom: stream. result nextPutAll: (self evaluateExpression: expression parameters: aCollection)] ifFalse: [ currentChar == $\ ifTrue: [stream atEnd ifFalse: [result nextPut: stream next]] ifFalse: [result nextPut: currentChar]]]. ^ result contents! ! !AbstractString methodsFor: '*morphic-Postscript Canvases' stamp: 'yo 11/3/2004 19:24'! asPostscript | temp | temp _ self asString copyReplaceAll: '(' with: '\('. temp _ temp copyReplaceAll: ')' with: '\)'. temp _ temp copyReplaceAll: ' ' with: ''. ^ PostscriptEncoder mapMacStringToPS: temp! ! !AbstractString methodsFor: '*versionnumber' stamp: 'yo 11/3/2004 19:24'! asVersion "Answer a VersionNumber" ^VersionNumber fromString: self! ! !AbstractString commentStamp: 'yo 10/19/2004 22:36' prior: 0! This class provides the abstract super class for the original String (that represents an array of 8-bit Characters) and MultiString (that represents an array of 32-bit MultiCharacters). In the similar manner of LargeInteger and SmallInteger, those subclasses are chosen accordingly for a string; namely as long as the system can figure out so, the String is used to represent the given string. The methods of this class were copied from String. Most of the methods only use #at: and #at:put: to access the elements and don't care about the actual type, so they work ok with proper accessors to the slots. Some of the methods of this class call #subclassResponsibility, and some other provides the default behavior and MultiString overrides the default behavior. Probably there should be a clearer organization in this regard. ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 14:50'! correspondingSymbolClass ^ self subclassResponsibility. ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! cr "Answer a string containing a single carriage return character." ^ self with: Character cr ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! crlf "Answer a string containing a carriage return and a linefeed." ^ self with: Character cr with: Character lf ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! crlfcrlf ^self crlf , self crlf. ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! fromPacked: aLong "Convert from a longinteger to a String of length 4." | s | s _ self new: 4. s at: 1 put: (aLong digitAt: 4) asCharacter. s at: 2 put: (aLong digitAt: 3) asCharacter. s at: 3 put: (aLong digitAt: 2) asCharacter. s at: 4 put: (aLong digitAt: 1) asCharacter. ^s "String fromPacked: 'TEXT' asPacked" ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! fromString: aString "Answer an instance of me that is a copy of the argument, aString." ^ aString copyFrom: 1 to: aString size! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! lf "Answer a string containing a single carriage return character." ^ self with: Character lf! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:27'! readFrom: inStream "Answer an instance of me that is determined by reading the stream, inStream. Embedded double quotes become the quote Character." | outStream char done | outStream _ WriteStream on: (self new: 16). "go to first quote" inStream skipTo: $'. done _ false. [done or: [inStream atEnd]] whileFalse: [char _ inStream next. char = $' ifTrue: [char _ inStream next. char = $' ifTrue: [outStream nextPut: char] ifFalse: [done _ true]] ifFalse: [outStream nextPut: char]]. ^outStream contents! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 11/3/2004 19:24'! tab "Answer a string containing a single tab character." ^ self with: Character tab ! ! !AbstractString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:29'! value: anInteger ^ self with: (Character value: anInteger). ! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 8/28/2002 13:31'! initialize "self initialize" | order | AsciiOrder _ (0 to: 255) as: ByteArray. CaseInsensitiveOrder _ AsciiOrder copy. ($a to: $z) do: [:c | CaseInsensitiveOrder at: c asciiValue + 1 put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)]. "Case-sensitive compare sorts space, digits, letters, all the rest..." CaseSensitiveOrder _ ByteArray new: 256 withAll: 255. order _ -1. ' 0123456789' do: "0..10" [:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. ($a to: $z) do: "11-64" [:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1). CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. 1 to: CaseSensitiveOrder size do: [:i | (CaseSensitiveOrder at: i) = 255 ifTrue: [CaseSensitiveOrder at: i put: (order _ order+1)]]. order = 255 ifFalse: [self error: 'order problem']. "a table for translating to lower case" LowercasingTable _ String withAll: (Character allCharacters collect: [:c | c asLowercase]). "a table for translating to upper case" UppercasingTable _ String withAll: (Character allCharacters collect: [:c | c asUppercase]). "a table for testing tokenish (for fast numArgs)" Tokenish _ String withAll: (Character allCharacters collect: [:c | c tokenish ifTrue: [c] ifFalse: [$~]]). "CR and LF--characters that terminate a line" CSLineEnders _ CharacterSet empty. CSLineEnders add: Character cr. CSLineEnders add: Character lf. "separators and non-separators" CSSeparators _ CharacterSet separators. CSNonSeparators _ CSSeparators complement.! ! !AbstractString class methodsFor: 'initialization' stamp: 'yo 8/11/2003 21:11'! initializeHtmlEntities "self initializeHtmlEntities" HtmlEntities _ (Dictionary new: 128) at: 'amp' put: $&; at: 'lt' put: $<; at: 'gt' put: $>; at: 'quot' put: $"; at: 'euro' put: Character euro; yourself. #('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter]! ! !AbstractString class methodsFor: 'examples' stamp: 'yo 11/3/2004 19:24'! example "To see the string displayed at the cursor point, execute this expression and select a point by pressing a mouse button." 'this is some text' displayOn: Display at: Sensor waitButton! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! findFirstInString: aString inSet: inclusionMap startingAt: start self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:06'! indexOfAscii: anInteger inString: aString startingAt: start self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! stringHash: aString initialHash: speciesHash self subclassResponsibility. ! ! !AbstractString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:32'! translate: aString from: start to: stop table: table self subclassResponsibility. ! ! !AcceptableCleanTextMorph methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 22:50'! accept "Overridden to allow accept of clean text" | textToAccept ok | textToAccept := textMorph asText. ok := setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]]. ok ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 12/23/2004 19:21'! checkName: aFileName fixErrors: fixing "Check if the file name contains any invalid characters" | fName hasBadChars correctedName newChar| fName _ super checkName: aFileName fixErrors: fixing. correctedName _ String streamContents:[:s| fName do:[:c| (newChar _ LegalCharMap at: c asciiValue +1) ifNotNil:[s nextPut: newChar]]]. hasBadChars _ fName ~= correctedName. (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. hasBadChars ifFalse:[^ fName]. ^ correctedName! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'tpr 11/5/2004 13:08'! fullPathFor: path "if the arg is an empty string, just return my path name converted via the language stuff. If the arg seems to be a rooted path, return it raw, assuming it is already ok. Otherwise cons up a path" path isEmpty ifTrue:[^pathName asSqueakPathName]. ((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path]. ^pathName asSqueakPathName, self slash, path! ! !AcornFileDirectory methodsFor: 'private' stamp: 'tpr 11/5/2004 13:08'! directoryContentsFor: fullPath "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." "FileDirectory default directoryContentsFor: ''" | entries extraPath | entries _ super directoryContentsFor: fullPath. fullPath isNullPath ifTrue: [ "For Acorn we also make sure that at least the parent of the current dir is added - sometimes this is in a filing system that has not been (or cannot be) polled for disc root names" extraPath _ self class default containingDirectory. "Only add the extra path if we haven't already got the root of the current dir in the list" entries detect: [:ent | extraPath fullName beginsWith: ent name] ifNone: [entries _ entries copyWith: (DirectoryEntry name: extraPath fullName creationTime: 0 modificationTime: 0 isDirectory: true fileSize: 0)]]. ^ entries ! ! !AcornFileDirectory methodsFor: 'testing' stamp: 'tpr 4/28/2004 21:54'! directoryExists: filenameOrPath "if the path is a root,we have to treat it carefully" (filenameOrPath endsWith: '$') ifTrue:[^(FileDirectory on: filenameOrPath) exists]. ^(self directoryNamed: filenameOrPath ) exists! ! !AcornFileDirectory methodsFor: 'path access' stamp: 'tpr 11/30/2003 21:42'! pathParts "Return the path from the root of the file system to this directory as an array of directory names. This version tries to cope with the RISC OS' strange filename formatting; filesystem::discname/$/path/to/file where the $ needs to be considered part of the filingsystem-discname atom." | pathList | pathList := super pathParts. (pathList indexOf: '$') = 2 ifTrue: ["if the second atom is root ($) then stick $ on the first atom and drop the second. Yuck" ^ Array streamContents: [:a | a nextPut: (pathList at: 1), '/$'. 3 to: pathList size do: [:i | a nextPut: (pathList at: i)]]]. ^ pathList! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:16'! isActiveDirectoryClass "Does this class claim to be that properly active subclass of FileDirectory for the current platform? On Acorn, the test is whether platformName is 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on older ones), which is what we would like to use for a dirsep if only it would work out. See pathNameDelimiter for more woeful details - then just get on and enjoy Squeak" ^ SmalltalkImage current platformName = 'RiscOS' or: [self primPathNameDelimiter = $.]! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'tpr 8/1/2003 16:38'! isCaseSensitive "Risc OS ignores the case of file names" ^ false! ! !AcornFileDirectory class methodsFor: 'class initialization' stamp: 'tpr 12/23/2004 19:20'! initialize "Set up the legal chars map for filenames. May need extending for unicode etc. Basic rule is that any char legal for use in filenames will have a non-nil entry in this array; except for space, this is the same character. Space is transcoded to a char 160 to be a 'hard space' " "AcornFileDirectory initialize" | aVal | LegalCharMap _ Array new: 256. Character alphabet do:[:c| LegalCharMap at: c asciiValue +1 put: c. LegalCharMap at: (aVal _ c asUppercase) asciiValue +1 put: aVal]. '`!!()-_=+[{]};~,./1234567890' do:[:c| LegalCharMap at: c asciiValue + 1 put: c]. LegalCharMap at: Character space asciiValue +1 put: (Character value:160 "hardspace"). LegalCharMap at: 161 put: (Character value:160 "hardspace")."secondary mapping to keep it in strings"! ! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:12'! asActionSequence ^self! ! !ActionSequence methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! asActionSequenceTrappingErrors ^WeakActionSequenceTrappingErrors withAll: self! ! !ActionSequence methodsFor: 'converting' stamp: 'reThink 2/18/2001 15:28'! asMinimalRepresentation self size = 0 ifTrue: [^nil]. self size = 1 ifTrue: [^self first]. ^self! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:51'! value "Answer the result of evaluating the elements of the receiver." | answer | self do: [:each | answer := each value]. ^answer! ! !ActionSequence methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 17:52'! valueWithArguments: anArray | answer | self do: [:each | answer := each valueWithArguments: anArray]. ^answer! ! !ActionSequence methodsFor: 'printing' stamp: 'SqR 07/28/2001 18:25'! printOn: aStream self size < 2 ifTrue: [^super printOn: aStream]. aStream nextPutAll: '#('. self do: [:each | each printOn: aStream] separatedBy: [aStream cr]. aStream nextPut: $)! ! !ActorState methodsFor: 'pen' stamp: 'nk 6/12/2004 16:36'! choosePenColor: evt owningPlayer costume changeColorTarget: owningPlayer costume selector: #penColor: originalColor: owningPlayer getPenColor hand: evt hand.! ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:42'! getPenArrowheads ^ penArrowheads == true! ! !ActorState methodsFor: 'pen' stamp: 'tk 10/4/2001 16:43'! setPenArrowheads: aBoolean penArrowheads _ aBoolean! ! !ActorState methodsFor: 'pen' stamp: 'sw 4/16/2003 12:26'! trailStyle "Answer the receiver's trailStyle. For backward compatibility, if the old penArrowheads slot is in found to be set, use it as a guide for initialization" ^ trailStyle ifNil: [trailStyle _ penArrowheads == true ifTrue: [#arrows] ifFalse: [#lines]]! ! !ActorState methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'! trailStyle: aSymbol "Set the trail style to the given symbol" trailStyle _ aSymbol! ! !AddedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! isAdded ^true! ! !AddedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! printEventKindOn: aStream aStream nextPutAll: 'Added'! ! !AddedEvent class methodsFor: 'accessing' stamp: 'rw 7/19/2003 09:52'! changeKind ^#Added! ! !AddedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:22'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! !AlertMorph methodsFor: 'accessing' stamp: 'mir 8/31/2004 15:47'! onColor ^onColor ifNil: [onColor := Color green]! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'! defaultColor "answer the default color/fill style for the receiver" ^ Color red! ! !AlertMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:11'! initialize "initialize the state of the receiver" super initialize. "" self extent: 25 @ 25. ! ! !AlertMorph methodsFor: 'stepping and presenter' stamp: 'mir 8/31/2004 15:47'! step super step. offColor ifNil: [offColor _ self onColor mixed: 0.5 with: Color black]. socketOwner objectsInQueue = 0 ifTrue: [ color = offColor ifFalse: [super color: offColor]. ] ifFalse: [ super color: (color = onColor ifTrue: [offColor] ifFalse: [onColor]). ]. ! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:02'! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:19'! initialize "initialize the state of the receiver" super initialize. "" self layoutPolicy: TableLayout new; listDirection: #leftToRight; wrapCentering: #topLeft; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2; rubberBandCells: true! ! !AlignmentMorph methodsFor: 'object fileIn' stamp: 'gm 2/22/2003 13:12'! convertOldAlignmentsNov2000: varDict using: smartRefStrm "major change - much of AlignmentMorph is now implemented more generally in Morph" "These are going away #('orientation' 'centering' 'hResizing' 'vResizing' 'inset' 'minCellSize' 'layoutNeeded' 'priorFullBounds')" | orientation centering hResizing vResizing inset minCellSize inAlignment | orientation := varDict at: 'orientation'. centering := varDict at: 'centering'. hResizing := varDict at: 'hResizing'. vResizing := varDict at: 'vResizing'. inset := varDict at: 'inset'. minCellSize := varDict at: 'minCellSize'. (orientation == #horizontal or: [orientation == #vertical]) ifTrue: [self layoutPolicy: TableLayout new]. self cellPositioning: #topLeft. self rubberBandCells: true. orientation == #horizontal ifTrue: [self listDirection: #leftToRight]. orientation == #vertical ifTrue: [self listDirection: #topToBottom]. centering == #topLeft ifTrue: [self wrapCentering: #topLeft]. centering == #bottomRight ifTrue: [self wrapCentering: #bottomRight]. centering == #center ifTrue: [self wrapCentering: #center. orientation == #horizontal ifTrue: [self cellPositioning: #leftCenter] ifFalse: [self cellPositioning: #topCenter]]. (inset isNumber or: [inset isPoint]) ifTrue: [self layoutInset: inset]. (minCellSize isNumber or: [minCellSize isPoint]) ifTrue: [self minCellSize: minCellSize]. (self hasProperty: #clipToOwnerWidth) ifTrue: [self clipSubmorphs: true]. "now figure out if our owner was an AlignmentMorph, even if it is reshaped..." inAlignment := false. owner isMorph ifTrue: [(owner isAlignmentMorph) ifTrue: [inAlignment := true]] ifFalse: ["e.g., owner may be reshaped" (owner class instanceVariablesString findString: 'orientation centering hResizing vResizing') > 0 ifTrue: ["this was an alignment morph being reshaped" inAlignment := true]]. "And check for containment in system windows" owner isSystemWindow ifTrue: [inAlignment := true]. (hResizing == #spaceFill and: [inAlignment not]) ifTrue: [self hResizing: #shrinkWrap] ifFalse: [self hResizing: hResizing]. (vResizing == #spaceFill and: [inAlignment not]) ifTrue: [self vResizing: #shrinkWrap] ifFalse: [self vResizing: vResizing]! ! !AlignmentMorph methodsFor: 'objects from disk' stamp: 'tk 11/26/2004 05:51'! convertToCurrentVersion: varDict refStream: smartRefStrm | newish | newish _ super convertToCurrentVersion: varDict refStream: smartRefStrm. "major change - much of AlignmentMorph is now implemented more generally in Morph" varDict at: 'hResizing' ifPresent: [ :x | ^ newish convertOldAlignmentsNov2000: varDict using: smartRefStrm]. ^ newish ! ! !AlignmentMorph methodsFor: 'visual properties' stamp: 'sw 11/5/2001 15:11'! canHaveFillStyles "Return true if the receiver can have general fill styles; not just colors. This method is for gradually converting old morphs." ^ self class == AlignmentMorph "no subclasses"! ! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! Used for layout. Since all morphs now support layoutPolicy the main use of this class is no longer needed. Kept around for compability. Supports a few methods not found elsewhere that can be convenient, eg. newRow ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! columnPrototype "Answer a prototypical column" | sampleMorphs aColumn | sampleMorphs _ #(red yellow green) collect: [:aColor | Morph new extent: 130 @ 38; color: (Color perform: aColor); setNameTo: aColor asString; yourself]. aColumn _ self inAColumn: sampleMorphs. aColumn setNameTo: 'Column'. aColumn color: Color veryVeryLightGray. aColumn cellInset: 4; layoutInset: 6. aColumn enableDragNDrop. aColumn setBalloonText: 'Things dropped into here will automatically be organized into a column. Once you have added your own items here, you will want to remove the sample colored rectangles that this started with, and you will want to change this balloon help message to one of your own!!' translated. ^ aColumn! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/2/2001 04:45'! inAColumn: aCollectionOfMorphs "Answer a columnar AlignmentMorph holding the given collection" | col | col _ self newColumn color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [:each | col addMorphBack: each]. ^ col! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'sw 11/5/2001 15:11'! inARow: aCollectionOfMorphs "Answer a row-oriented AlignmentMorph holding the given collection" | aRow | aRow _ self newRow color: Color transparent; vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 1; borderColor: Color black; borderWidth: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | aRow addMorphBack: each]. ^ aRow! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'dgd 9/20/2003 19:05'! rowPrototype "Answer a prototypical row" | sampleMorphs aRow | sampleMorphs _ (1 to: (2 + 3 atRandom)) collect: [:integer | EllipseMorph new extent: ((60 + (20 atRandom)) @ (80 + ((20 atRandom)))); color: Color random; setNameTo: ('egg', integer asString); yourself]. aRow _ self inARow: sampleMorphs. aRow setNameTo: 'Row'. aRow enableDragNDrop. aRow cellInset: 6. aRow layoutInset: 8. aRow setBalloonText: 'Things dropped into here will automatically be organized into a row. Once you have added your own items here, you will want to remove the sample colored eggs that this started with, and you will want to change this balloon help message to one of your own!!' translated. aRow color: Color veryVeryLightGray. ^ aRow "AlignmentMorph rowPrototype openInHand"! ! !AlignmentMorph class methodsFor: 'parts bin' stamp: 'sw 11/16/2001 09:16'! supplementaryPartsDescriptions "Extra items for parts bins" ^ {DescriptionForPartsBin formalName: 'Column' categoryList: #('Presentation') documentation: 'An object that presents the things within it in a column' globalReceiverSymbol: #AlignmentMorph nativitySelector: #columnPrototype. DescriptionForPartsBin formalName: 'Row' categoryList: #('Presentation') documentation: 'An object that presents the things within it in a row' globalReceiverSymbol: #AlignmentMorph nativitySelector: #rowPrototype}! ! !AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2001 10:01'! additionsToViewerCategories "Answer viewer additions for the 'layout' category" ^#(( layout ( (slot cellInset 'The cell inset' Number readWrite Player getCellInset Player setCellInset:) (slot layoutInset 'The layout inset' Number readWrite Player getLayoutInset Player setLayoutInset:) (slot listCentering 'The list centering' ListCentering readWrite Player getListCentering Player setListCentering:) (slot hResizing 'Horizontal resizing' Resizing readWrite Player getHResizing Player setHResizing:) (slot vResizing 'Vertical resizing' Resizing readWrite Player getVResizing Player setVResizing:) (slot listDirection 'List direction' ListDirection readWrite Player getListDirection Player setListDirection:) (slot wrapDirection 'Wrap direction' ListDirection readWrite Player getWrapDirection Player setWrapDirection:) ))) ! ! !AlignmentMorph class methodsFor: 'scripting' stamp: 'sw 11/16/2004 00:44'! defaultNameStemForInstances "The code just below, now commented out, resulted in every instance of every sublcass of AlignmentMorph being given a default name of the form 'Alignment1', rather than the desired 'MoviePlayer1', 'ScriptEditor2', etc." "^ 'Alignment'" ^ super defaultNameStemForInstances! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:54'! acceptDroppingMorph: aMorph event: evt | handlerForDrops | handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [ ^super acceptDroppingMorph: aMorph event: evt ]. (handlerForDrops acceptDroppingMorph: aMorph event: evt in: self) ifFalse: [ aMorph rejectDropMorphEvent: evt. "send it back where it came from" ].! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'dgd 8/27/2004 18:26'! fancyText: aString ofSize: pointSize color: aColor | answer tm | answer _ self inAColumn: { tm _ TextMorph new beAllFont: ((TextStyle default fontOfSize: pointSize) emphasized: 1); color: aColor; contents: aString }. tm addDropShadow. tm shadowPoint: (5@5) + tm bounds center. tm lock. ^answer ! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'ar 12/30/2001 19:14'! fullDrawOn: aCanvas | mask | (aCanvas isVisible: self fullBounds) ifFalse:[^self]. super fullDrawOn: aCanvas. mask _ self valueOfProperty: #disabledMaskColor ifAbsent: [^self]. aCanvas fillRectangle: bounds color: mask. ! ! !AlignmentMorphBob1 methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 08:36'! wantsDroppedMorph: aMorph event: evt | handlerForDrops | handlerForDrops _ self valueOfProperty: #handlerForDrops ifAbsent: [ ^super wantsDroppedMorph: aMorph event: evt ]. ^handlerForDrops wantsDroppedMorph: aMorph event: evt in: self! ! !AllPlayersTool methodsFor: 'initialization' stamp: 'sw 12/8/2004 11:12'! addHeaderRow "Add the header morph at the top of the tool" | aRow title aButton | aRow _ AlignmentMorph newRow. aRow listCentering: #justified; color: Color transparent. aButton _ self tanOButton. aButton actionSelector: #delete. aRow addMorphFront: aButton. aRow addMorphBack: (title _ StringMorph contents: 'Gallery of Players' translated). title setBalloonText: 'Double-click here to refresh the contents' translated. title on: #doubleClick send: #reinvigorate to: self. aRow addMorphBack: self helpButton. self addMorphFront: aRow. ! ! !AllPlayersTool methodsFor: 'initialization' stamp: 'sw 7/28/2004 20:48'! initializeFor: aPresenter "Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter" | placeHolder | self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap. self useRoundedCorners. self borderStyle: BorderStyle complexAltInset; borderWidth: 4; borderColor: (Color r: 0.452 g: 0.839 b: 1.0). "Color fromUser" self addHeaderRow. placeHolder _ Morph new beTransparent. placeHolder extent: 200@1. self addMorphBack: placeHolder. ActiveWorld presenter reinvigoratePlayersTool: self ! ! !AllPlayersTool methodsFor: 'initialization' stamp: 'sw 7/28/2004 18:08'! initializeToStandAlone "Initialize the receiver" super initializeToStandAlone. self layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #spaceFill; extent: 1@1; vResizing: #spaceFill; rubberBandCells: true; yourself. self initializeFor: self currentWorld presenter! ! !AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:37'! invigorateButton "Answer a button that triggers reinvigoration" | aButton | aButton _ IconicButton new target: self; borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: #Refresh); color: Color transparent; actWhen: #buttonUp; actionSelector: #reinvigorate; yourself. aButton setBalloonText: 'Click here to refresh the list of players'. ^ aButton ! ! !AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/19/2004 16:17'! menuButton "Answer a button that brings up a menu. Useful when adding new features, but at present is between uses" | aButton | aButton _ IconicButton new target: self; borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: #TinyMenu); color: Color transparent; actWhen: #buttonDown; actionSelector: #offerMenu; yourself. aButton setBalloonText: 'click here to get a menu with further options'. ^ aButton ! ! !AllPlayersTool methodsFor: 'reinvigoration' stamp: 'sw 7/28/2004 18:08'! reinvigorate "Referesh the contents of the receiver" (submorphs copyFrom: 3 to: submorphs size) do: [:m | m delete]. ActiveWorld doOneCycleNow. self playSoundNamed: 'scritch'. (Delay forMilliseconds: 700) wait. ActiveWorld presenter reinvigoratePlayersTool: self. self playSoundNamed: 'scratch'! ! !AllPlayersTool methodsFor: 'menus' stamp: 'sw 7/28/2004 18:32'! addCustomMenuItems: aMenu hand: aHand "Add further items to the menu" aMenu add: 'reinvigorate' target: self action: #reinvigorate. Preferences eToyFriendly ifFalse: [aMenu add: 'inspect' target: self action: #inspect]! ! !AllPlayersTool methodsFor: 'menus' stamp: 'sw 7/28/2004 22:58'! presentHelp "Sent when a Help button is hit; provide the user with some form of help for the tool at hand" | aString aTextMorph | aString _ 'About the Gallery of Players Click on an object''s picture to reveal its location. Click on the turquoise eye to open the object''s viewer. Click on an object''s name to obtain a tile representing the object. Double-click on the title ("Gallery of Players") to refresh the tool; this may allow you to see newly-added or newly-scripted objects.'. aTextMorph _ TextMorph new contents: aString translated. aTextMorph useRoundedCorners; borderWidth: 3; borderColor: Color gray; margins: 3@3. aTextMorph backgroundColor: Color blue muchLighter. aTextMorph beAllFont: (StrikeFont familyName: #ComicBold size: 18); centered; lock. AlignmentMorph new beTransparent hResizing: #shrinkWrap; vResizing: #shrinkWrap; addMorphBack: aTextMorph; openInHand! ! !AllPlayersTool commentStamp: '' prior: 0! A tool that lets you see find, view, and obtain tiles for all the active players in the project.! !AllPlayersTool class methodsFor: 'parts bin' stamp: 'sw 7/19/2004 10:37'! descriptionForPartsBin "Answer a description for use in parts bins" ^ self partName: 'Players' categories: #('Scripting') documentation: 'A tool showing all the players in your project'! ! !AllPlayersTool class methodsFor: 'instance-creation defaults' stamp: 'sw 7/19/2004 10:38'! defaultNameStemForInstances "Answer the default name stem for new instances of this class" ^ 'Players'! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:34'! addSecondLineOfControls "Add the second line of controls" | aRow outerButton aButton worldToUse | aRow _ AlignmentMorph newRow listCentering: #center; color: Color transparent. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingOnlyActiveScripts; getSelector: #showingOnlyActiveScripts. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'tickers only' translated) lock. outerButton setBalloonText: 'If checked, then only scripts that are paused or ticking will be shown' translated. aRow addMorphBack: outerButton. aRow addTransparentSpacerOfSize: 20@0. aRow addMorphBack: self helpButton. aRow addTransparentSpacerOfSize: 20@0. outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleWhetherShowingAllInstances; getSelector: #showingAllInstances. outerButton addTransparentSpacerOfSize: (4@0). outerButton addMorphBack: (StringMorph contents: 'all instances' translated) lock. outerButton setBalloonText: 'If checked, then entries for all instances will be shown, but if not checked, scripts for only one representative of each different kind of object will be shown. Consult the help available by clicking on the purple ? for more information.' translated. aRow addMorphBack: outerButton. self addMorphBack: aRow. worldToUse _ self isInWorld ifTrue: [self world] ifFalse: [ActiveWorld]. worldToUse presenter reinvigorateAllScriptsTool: self. self layoutChanged.! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 8/31/2003 19:43'! dismissButton "Answer a button whose action would be to dismiss the receiver " | aButton | aButton := super dismissButton. aButton setBalloonText: 'Click here to remove this tool from the screen; you can get another one any time you want from the Widgets flap' translated. ^ aButton! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'sw 12/8/2004 11:26'! initializeFor: ignored "Initialize the receiver as a tool which shows, and allows the user to change the status of, all the instantiations of all the user-written scripts in the scope of the containing pasteup's presenter" | aRow aButton | showingOnlyActiveScripts _ true. showingAllInstances _ true. showingOnlyTopControls _ true. self color: Color brown muchLighter muchLighter; wrapCentering: #center; cellPositioning: #topCenter; vResizing: #shrinkWrap; hResizing: #shrinkWrap. self useRoundedCorners. self borderWidth: 4; borderColor: Color brown darker. aRow _ AlignmentMorph newRow. aRow listCentering: #justified; color: Color transparent. aButton _ self tanOButton. aButton actionSelector: #delete. aRow addMorphFront: aButton. aRow addMorphBack: ScriptingSystem scriptControlButtons. aRow addMorphBack: self openUpButton. self addMorphFront: aRow. ! ! !AllScriptsTool methodsFor: 'initialization' stamp: 'dgd 9/19/2003 14:35'! presentHelp "Sent when a Help button is hit; provide the user with some form of help for the tool at hand" | aString | aString _ 'This tool allows you to see all the scripts for all the objects in this project. Sometimes you are only interested in those scripts that are ticking, or that are *ready* to tick when you hit the GO button (which are said to be "paused.") Check "tickers only" if you only want to see such scripts -- i.e., scripts that are either paused or ticking. If "tickers only" is *not* checked, then all scripts will be shown, whatever their status. The other checkbox, labeled "all instances", only comes into play if you have created "multiple sibling instances" (good grief) of the same object, which share the same scripts; if you have such things, it is often convenient to see the scripts of just *one* such sibling, because it will take up less space and require less mindshare -- and note that you can control a script for an object *and* all its siblings from the menu of that one that you see, via menu items such as "propagate status to siblings". If "all instances" is checked, scripts for all sibling instances will be shown, whereas if "all instances" is *not* checked, only one of each group of siblings will be selected to have its scripts shown. But how do you get "multiple sibling instances" of the same object? There are several ways: (1) Use the "make a sibling instance" or the "make multiple siblings..." menu item in the halo menu of a scripted object (2) Use the "copy" tile in a script. (3) Request "give me a copy now" from the menu associated with the "copy" item in a Viewer If you have on your screen multiple sibling instances of the same object, then you may or may want to see them all in the All Scripts tool, and that is what the "all instances" checkbox governs. Set "all instances" if you want a separate entry for each instance, as opposed to a single representative of that kind of object. Note that if you obtain a copy of an object by using the green halo handle, it will *not* be a sibling instance of the original. It will in many ways seem to be, because it will start out its life having the same scripts as the original. But it will then lead an independent life, so that changes to scripts of the original will not be reflected in it, and vice-versa. This is an important distinction, and an unavoidable one because people sometimes want the deep sharing of sibling instances and sometimes they clearly do not. But the truly understandable description of these concepts and distinctions certainly lies *ahead* of us!!'. (StringHolder new contents: aString translated) openLabel: 'About the All Scripts tool' translated! ! !AllScriptsTool methodsFor: 'parts bin' stamp: 'dgd 2/22/2003 19:37'! initializeToStandAlone super initializeToStandAlone. self layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #spaceFill; extent: 1 @ 1; vResizing: #spaceFill; rubberBandCells: true. self initializeFor: self currentWorld presenter! ! !AllScriptsTool methodsFor: 'stepping and presenter' stamp: 'sw 11/14/2001 00:31'! step "If the list of scripts to show has changed, refresh my contents" self showingOnlyTopControls ifFalse: [self presenter reinvigorateAllScriptsTool: self].! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 12/8/2004 11:28'! openUpButton "Answer a button whose action would be to open up the receiver or snap it back closed" | aButton aForm | aButton _ IconicButton new borderWidth: 0. aForm _ ScriptingSystem formAtKey: #PowderBlueOpener. aForm ifNil: [aForm _ Form extent: 13@22 depth: 16 fromArray: #( 0 0 12017 787558129 0 0 0 0 12017 787561309 995965789 787558129 0 0 0 787561309 995965789 995965789 995965789 787546112 0 12017 995965789 995965789 995965789 995965789 995962609 0 12017 995965789 995965789 995965789 995965789 995962609 0 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995950593 80733 995965789 995965789 787546112 787561309 995965789 65537 65537 80733 995965789 787546112 787561309 995950593 80733 995950593 80733 995965789 787546112 787561309 995950593 80733 995950593 80733 995965789 787546112 787561309 995950593 65537 65537 80733 995965789 787546112 787561309 995965789 65537 65537 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 787561309 995965789 995965789 995965789 995965789 995965789 787546112 12017 995965789 995965789 995965789 995965789 995962609 0 12017 995965789 995965789 995965789 995965789 995962609 0 0 787561309 995965789 995965789 995965789 787546112 0 0 12017 787561309 995965789 787558129 0 0 0 0 12017 787558129 0 0 0) offset: 0@0. ScriptingSystem saveForm: aForm atKey: #PowderBlueOpener]. aButton labelGraphic: aForm. aButton target: self; color: Color transparent; actionSelector: #toggleWhetherShowingOnlyTopControls; setBalloonText: 'open or close the lower portion that shows individual scripts' translated. ^ aButton! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/13/2001 19:43'! showingOnlyTopControls "Answer whether the receiver is currently showing only the top controls" ^ showingOnlyTopControls ifNil: [showingOnlyTopControls _ true]! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingAllInstances "Toggle whether the receiver is showing all instances or only one exemplar per uniclass" showingAllInstances _ showingAllInstances not. self presenter reinvigorateAllScriptsTool: self! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingOnlyActiveScripts "Toggle whether the receiver is showing only active scripts" showingOnlyActiveScripts _ showingOnlyActiveScripts not. self presenter reinvigorateAllScriptsTool: self! ! !AllScriptsTool methodsFor: 'toggles' stamp: 'sw 11/14/2001 00:32'! toggleWhetherShowingOnlyTopControls "Toggle whether the receiver is showing only the stop/step/go line or the full whammy" | aCenter | showingOnlyTopControls _ self showingOnlyTopControls not. aCenter _ self center x. self showingOnlyTopControls ifTrue: [self removeAllButFirstSubmorph] ifFalse: [self addSecondLineOfControls. self presenter reinvigorateAllScriptsTool: self]. WorldState addDeferredUIMessage: [self center: (aCenter @ self center y)] ! ! !AllScriptsTool commentStamp: '' prior: 0! A tool for controlling and viewing all scripts in a project. The tool has an open and a closed form. In the closed form, stop-step-go buttons are available, plus a control for opening the tool up. In the open form, it has a second row of controls that govern which scripts should be shown, followed by the individual script items.! !AllScriptsTool class methodsFor: 'instance creation' stamp: 'sw 6/12/2001 11:52'! allScriptsToolForActiveWorld "Launch an AllScriptsTool to view scripts of the active world" | aTool | aTool _ self newColumn. aTool initializeFor: ActiveWorld presenter. ^ aTool! ! !AllScriptsTool class methodsFor: 'parts bin' stamp: 'sw 11/13/2001 18:31'! descriptionForPartsBin "Answer a description for use in parts bins" ^ self partName: 'All Scripts' categories: #('Scripting') documentation: 'A tool allowing you to monitor and change the status of all scripts in your project'! ! !AllScriptsTool class methodsFor: 'printing' stamp: 'sw 11/13/2001 19:44'! defaultNameStemForInstances "Answer the default name stem for new instances of this class" ^ 'All Scripts'! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:28'! initialize self registerInFlapsRegistry. ! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:30'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you see and control all the running scripts in your project') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you control all the running scripts in your world') forFlapNamed: 'Scripting'. cl registerQuad: #(AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you see and control all the running scripts in your project') forFlapNamed: 'Widgets']! ! !AllScriptsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:30'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha _ newAlpha.! ! !AlphaBlendingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:18'! on: aCanvas myCanvas _ aCanvas. alpha _ 1.0.! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'bf 10/28/2003 15:46'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." rule = Form paint ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form paintAlpha alpha: alpha. ]. rule = Form over ifTrue:[ ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: Form blendAlpha alpha: alpha. ].! ! !AlphaBlendingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:23'! mapColor: aColor aColor isColor ifFalse:[^aColor]. "Should not happen but who knows..." aColor isTransparent ifTrue:[^aColor]. aColor isOpaque ifTrue:[^aColor alpha: alpha]. ^aColor alpha: (aColor alpha * alpha)! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! dependenciesForClass: aClass | r | r := Set new. aClass methodDict values do: [:cm | (cm literals select: [:l | l isKindOf: LookupKey]) do: [:ll | ll key ifNotNil: [r add: ll key]]]. ^ r! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! externalReference ^ self ! ! !Analyzer class methodsFor: 'dependencies' stamp: 'md 10/29/2003 23:40'! externalReferenceOf: aCollectionOfClass | r | r := Set new. aCollectionOfClass do: [:cls | r addAll: (self dependenciesForClass: cls)]. aCollectionOfClass do: [:clss | r remove: clss name ifAbsent: []]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! doesClass: cls define: aSelector ^ cls methodDict includesKey: aSelector ! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsCalledAndCalleeForClass: aClass | r | r := Set new. aClass methodDict associationsDo: [:assoc | (assoc value literals select: [:l | l isKindOf: Symbol]) do: [:ll | r add: (Array with: assoc key with: ll)]]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsCalledForClass: aClass | r | r := Set new. aClass methodDict values do: [:cm | (cm literals select: [:l | l isKindOf: Symbol]) do: [:ll | r add: ll]]. ^ r! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:39'! methodsDefinedForClass: aClass ^ aClass methodDict keys ! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'! methodsIn: cls callingMethodsDefinedIn: classes "Give collection matching (m1, m2) where: - m1 is defined in C - m2 is defined in classes - m2 called in m1 of C, - and m2 not defined in C" "We made the following assumption: If a method foo is in defined in cls and in classes, then if cls call foo, then it calls its own" | methodsCalled allMethodsDefined ans | methodsCalled := self methodsCalledAndCalleeForClass: cls. allMethodsDefined := Set new. classes do: [:clss | allMethodsDefined addAll: (self methodsDefinedForClass: clss)]. ans := methodsCalled select: [:calleeCalled | (self doesClass: cls define: calleeCalled second) not and: [allMethodsDefined includes: calleeCalled second]]. ^ ans! ! !Analyzer class methodsFor: 'methods' stamp: 'md 10/29/2003 23:40'! referingMethodsDefinedInSubclasses: aClass | r | r := self methodsCalledForClass: aClass. subclasses := aClass allSubclasses. subclasses remove: aClass! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example1 "self example1" Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname]) inspect ! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example2 "self example2" (Analyzer externalReferenceOf: (#(#Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example3 "self example3" (((Analyzer externalReferenceOf: (#(#Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) select: [:clsName | (Smalltalk includesKey: clsName) and: [(Smalltalk at: clsName) isKindOf: Class]]) select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example4 "self example4" (((Analyzer externalReferenceOf: (#(#Object #Behavior #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname])) select: [:clsName | (Smalltalk includesKey: clsName) and: [(Smalltalk at: clsName) isKindOf: Class]]) select: [:clssName | ((Smalltalk at: clssName) category asString beginsWith: 'Kernel') not]) inspect! ! !Analyzer class methodsFor: 'examples' stamp: 'md 10/29/2003 23:39'! example5 "self example5" | classes | classes := #(#ClassBuilder #ClassDescription #Class ) collect: [:clsname | Smalltalk at: clsname]. (Analyzer methodsIn: Behavior callingMethodsDefinedIn: classes) inspect! ! !AnalyzerTest methodsFor: 'utility' stamp: 'ab 3/8/2003 13:55'! createClass: aClassname ^ self createClass: aClassname superclass: Object ! ! !AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:42'! createClass: aClassname superclass: aClass | r | r _ aClass subclass: aClassname instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-KCP'. classesCreated add: r. ^ r! ! !AnalyzerTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:41'! removeClassIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls | cls removeFromSystem] ! ! !AnalyzerTest methodsFor: 'utility' stamp: 'rw 5/12/2003 11:56'! removeClassNamedIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem]. Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! ! !AnalyzerTest methodsFor: 'running' stamp: 'ab 3/8/2003 13:54'! setUp classesCreated _ OrderedCollection new! ! !AnalyzerTest methodsFor: 'running' stamp: 'sd 5/23/2003 14:51'! tearDown | name | classesCreated do: [:cls | name _ cls name. self removeClassNamedIfExists: name. ChangeSet current removeClassChanges: name]. classesCreated _ nil! ! !AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'! testDependenciesForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. "-------" r _ Analyzer dependenciesForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection )). ! ! !AnalyzerTest methodsFor: 'dependencies' stamp: 'ab 3/8/2003 14:04'! testExternalReferenceOf | r cls1 cls2 cls3 | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2. cls3 _ self createClass: #MyClass3. "-------" cls1 compile: 'foo ^ MyClass2'. cls1 compile: 'bar MyClass1 show: ''blah blah'''. cls1 compile: 'zork OrderedCollection new'. cls1 compile: 'baz Morph new openInWorld'. "-------" cls2 compile: 'foo ^ Object'. cls2 compile: 'bar Transcript show: ''blah blah'''. cls2 compile: 'zork OrderedCollection new'. "-------" cls3 compile: 'foo ^ Object'. cls3 compile: 'bar Transcript show: ''blah blah'''. cls3 compile: 'zork MyClass3 new'. "-------" r _ Analyzer externalReferenceOf: (#(#MyClass1 #MyClass2 #MyClass3 ) collect: [:clsName | Smalltalk at: clsName]). self assert: r size = 4. self assert: (r includesAllOf: #(#Object #Transcript #OrderedCollection #Morph )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodCallDefinedInSubclasses | cls1 cls2 r | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2 superclass: cls1. "-------" cls1 compile: 'foo ^ self bar'. cls2 compile: 'bar ^ true'. "-------" self assert: cls2 new foo. r _ Analyzer methodsIn: cls1 callingMethodsDefinedIn: (Array with: cls2). r _ r asOrderedCollection. self assert: r size = 1. self assert: r first size = 2. self assert: r first first == #foo. self assert: r first second == #bar. ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodCallDefinedInSubclasses2 | cls1 cls2 r cls3 cls4 | cls1 _ self createClass: #MyClass1. cls2 _ self createClass: #MyClass2 superclass: cls1. cls3 _ self createClass: #MyClass3. cls4 _ self createClass: #MyClass4 superclass: cls3. "-------" cls1 compile: 'foo ^ self f1; f2'. cls1 compile: 'bar ^ self f3; foo'. cls1 compile: 'zork ^ self bar; blah'. cls2 compile: 'f1 ^ true'. cls2 compile: 'f2 ^ true'. cls3 compile: 'f3 ^ true'. cls3 compile: 'foo ^ true'. cls4 compile: 'f3 ^ true'. cls4 compile: 'f4 ^ true'. cls4 compile: 'bleubleu ^ true'. cls4 compile: 'bouba ^ true'. "-------" r _ Analyzer methodsIn: cls1 callingMethodsDefinedIn: (Array with: cls2 with: cls3 with: cls4). r _ r asOrderedCollection. self assert: r size = 3. self assert: (r includesAllOf: #(#(#foo #f1) #(#foo #f2) #(#bar #f3) )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodsCalledAndCalleeForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. cls compile: 'foobar Object new asMorph; beep'. "-------" r _ Analyzer methodsCalledAndCalleeForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#(#bar #show:) #(#foobar #asMorph) #(#foobar #asMorph) )). ! ! !AnalyzerTest methodsFor: 'methods' stamp: 'ab 3/8/2003 14:03'! testMethodsCalledForClass | cls r | cls _ self createClass: #MyClass. "-------" cls compile: 'foo ^ Object'. cls compile: 'bar Transcript show: ''blah blah'''. cls compile: 'zork OrderedCollection new'. cls compile: 'foobar Object new asMorph; beep'. "-------" r _ Analyzer methodsCalledForClass: cls. self assert: r size = 3. self assert: (r includesAllOf: #(#beep #show: #asMorph )). ! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'bf 2/25/2005 11:11'! allImages | body colorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: (stream contentsOfEntireFile))]. localColorTable _ nil. forms _ OrderedCollection new. delays _ OrderedCollection new. comments _ OrderedCollection new. self readHeader. [(body _ self readBody) == nil] whileFalse: [colorTable _ localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [transparentIndex + 1 > colorTable size ifTrue: [colorTable _ colorTable forceTo: transparentIndex + 1 paddingWith: Color white]. colorTable at: transparentIndex + 1 put: Color transparent]. body colors: colorTable. forms add: body. delays add: delay]. ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !AnimatedGIFReadWriter methodsFor: 'accessing' stamp: 'mir 11/19/2003 14:16'! forms ^ forms! ! !AnimatedGIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! !AnimatedGIFReadWriter methodsFor: 'private' stamp: 'mir 11/19/2003 12:25'! comment: aString comments add: aString! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'! formsFromFileNamed: fileName | stream | stream _ FileStream readOnlyFileNamed: fileName. ^ self formsFromStream: stream! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'mir 11/18/2003 17:00'! formsFromStream: stream | reader | reader _ self new on: stream reset. Cursor read showWhile: [reader allImages. reader close]. ^reader! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 6/12/2004 13:12'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('gif')! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'bf 2/25/2005 11:06'! step | f d | images isEmpty ifTrue: [^ self]. nextTime > Time millisecondClockValue ifTrue: [^self]. imageIndex _ imageIndex \\ images size + 1. f _ images at: imageIndex. f displayOn: self image at: 0@0 rule: Form paint. self invalidRect: (self position + f offset extent: f extent). d _ (delays at: imageIndex) ifNil: [0]. nextTime := Time millisecondClockValue + d ! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'! stepTime ^stepTime ifNil: [super stepTime]! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'mir 11/19/2003 13:40'! stepTime: anInteger stepTime _ anInteger! ! !AnimatedImageMorph methodsFor: 'stepping and presenter' stamp: 'asm 12/15/2003 19:44'! wantsSteps ^(images size > 1) ! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'! fromGIFFileNamed: fileName self fromReader: (AnimatedGIFReadWriter formsFromFileNamed: fileName)! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:18'! fromReader: reader images _ reader forms. delays _ reader delays. imageIndex _ 0. self image: (Form extent: images first extent depth: 32). self step! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'nk 2/15/2004 15:20'! fromStream: aStream self fromReader: (AnimatedGIFReadWriter formsFromStream: aStream)! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'mir 11/19/2003 13:42'! images ^images! ! !AnimatedImageMorph methodsFor: 'private' stamp: 'bf 2/25/2005 11:09'! initialize nextTime := Time millisecondClockValue. imageIndex := 1. stepTime := 10. super initialize! ! !AnimatedImageMorph commentStamp: '' prior: 0! I am an ImageMorph that can hold more than one image. Each image has its own delay time.! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:23'! fromGIFFileNamed: fileName | reader | reader _ AnimatedGIFReadWriter formsFromFileNamed: fileName. ^reader forms size = 1 ifTrue: [ ImageMorph new image: reader forms first ] ifFalse: [ self new fromReader: reader ]! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 15:27'! fromStream: aStream | reader | reader _ AnimatedGIFReadWriter formsFromStream: aStream. ^reader forms size = 1 ifTrue: [ ImageMorph new image: reader forms first ] ifFalse: [ self new fromReader: reader ]! ! !AnimatedImageMorph class methodsFor: 'instance creation' stamp: 'nk 2/15/2004 16:57'! openGIFInWindow: aStream ^(self fromStream: aStream binary) openInWorld! ! !AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:05'! initialize "register the receiver in the global registries" self environment at: #FileList ifPresent: [:cl | cl registerFileReader: self]! ! !AnimatedImageMorph class methodsFor: 'class initialization' stamp: 'asm 12/11/2003 21:01'! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 13:11'! fileReaderServicesForFile: fullName suffix: suffix ^((AnimatedGIFReadWriter typicalFileExtensions asSet add: '*'; add: 'form'; yourself) includes: suffix) ifTrue: [ self services ] ifFalse: [#()] ! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35'! serviceOpenGIFInWindow "Answer a service for opening a gif graphic in a window" ^ (SimpleServiceEntry provider: self label: 'open graphic in a window' selector: #openGIFInWindow: description: 'open a GIF graphic file in a window' buttonLabel: 'open') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !AnimatedImageMorph class methodsFor: 'fileIn/Out' stamp: 'asm 12/11/2003 21:54'! services ^ Array with: self serviceOpenGIFInWindow with: Form serviceImageImports with: Form serviceImageAsBackground ! ! !AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 21:19'! callingAThirdMethod self inform: ';lkl;'. self zoulouSymbol! ! !AnotherDummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:49'! zoulouSymbol self callingAThirdMethod! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'! isCarryingFood ^ isCarryingFood ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'! isCarryingFood: aBoolean isCarryingFood _ aBoolean. ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:24'! pheromoneDropSize ^ pheromoneDropSize ! ! !AntColonyTurtle methodsFor: 'variables' stamp: 'jm 2/26/2000 10:25'! pheromoneDropSize: aNumber pheromoneDropSize _ aNumber. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:26'! dropFoodInNest (isCarryingFood and: [(self get: 'isNest') > 0]) ifTrue: [ self color: Color black. isCarryingFood _ false. "turn around and go forward to try to pick up pheromone trail" self turnRight: 180. self forward: 3]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 3/8/2001 14:22'! pickUpFood | newFood | (isCarryingFood not and: [(self get: 'food') > 0]) ifTrue: [ newFood _ (self get: 'food') - 1. self set: 'food' to: newFood. newFood = 0 ifTrue: [self patchColor: world backgroundColor]. isCarryingFood _ true. pheromoneDropSize _ 800. self color: Color red. "drop a blob of pheromone on the side of the food farthest from nest" self turnTowardsStrongest: 'nestScent'. self turnRight: 180. self forward: 4. self increment: 'pheromone' by: 5000]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 19:20'! returnToNest isCarryingFood ifTrue: [ "decrease size of pheromone drops to create a gradient back to food" pheromoneDropSize > 0 ifTrue: [ self increment: 'pheromone' by: pheromoneDropSize. pheromoneDropSize _ pheromoneDropSize - 20]. self turnTowardsStrongest: 'nestScent'. self forward: 1]. ! ! !AntColonyTurtle methodsFor: 'demons' stamp: 'jm 2/7/2001 08:12'! searchForFood "If you smell pheromone, go towards the strongest smell. Otherwise, wander aimlessly." isCarryingFood ifFalse: [ ((self get: 'pheromone') > 1) ifTrue: [self turnTowardsStrongest: 'pheromone'] ifFalse: [ self turnRight: (self random: 40). self turnLeft: (self random: 40)]. self forward: 1]. ! ! !AppRegistry methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:04'! seeClassSide "All the code for AppRegistry is on the class side."! ! !AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! AppRegistry is a simple little class, not much more than a wrapper around a collection. It's intended to help break dependencies between packages. For example, if you'd like to be able to send e-mail, you could use the bare-bones MailComposition class, or you could use the full-blown Celeste e-mail client. Instead of choosing one or the other, you can call "MailSender default" (where MailSender is a subclass of AppRegistry), and thus avoid creating a hard-coded dependency on either of the two mail senders. This will only really be useful, of course, for applications that have a very simple, general, well-defined interface. Most of the time, you're probably better off just marking your package as being dependent on a specific other package, and avoiding the hassle of this whole AppRegistry thing. But for simple things like e-mail senders or web browsers, it might be useful. ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:36'! appName "Defaults to the class name, which is probably good enough, but you could override this in subclasses if you want to." ^ self name! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'md 12/1/2004 23:58'! askForDefault | menu | self registeredClasses isEmpty ifTrue: [self inform: 'There are no ', self appName, ' applications registered.'. ^ default _ nil]. self registeredClasses size = 1 ifTrue: [^ default _ self registeredClasses anyOne]. menu _ CustomMenu new. self registeredClasses do: [:c | menu add: c name printString action: c]. default _ menu startUpWithCaption: 'Which ', self appName, ' would you prefer?'. default ifNil: [default := self registeredClasses first]. ^default.! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:33'! default: aClassOrNil "Sets my default to aClassOrNil. Answers the old default." | oldDefault | oldDefault := default. aClassOrNil ifNotNil: [ self register: aClassOrNil ]. default := aClassOrNil. ^ oldDefault! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 4/2/2003 15:25'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [default _ nil. "so it'll ask for a new default, since if you're registering a new app you probably want to use it" self registeredClasses add: aProviderClass].! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses _ OrderedCollection new]! ! !AppRegistry class methodsFor: 'as yet unclassified' stamp: 'ads 3/29/2003 13:03'! unregister: aProviderClass (default = aProviderClass) ifTrue: [default _ nil]. self registeredClasses remove: aProviderClass ifAbsent: [].! ! !ArbitraryObjectSocket methodsFor: 'private' stamp: 'mir 5/15/2003 15:35'! processInput "recieve some data" | inObjectData | "read as much data as possible" self addToInBuf: socket receiveAvailableData. "decode as many objects as possible" [self nextObjectLength ~~ nil and: [ self nextObjectLength <= (self inBufSize + 4) ]] whileTrue: [ "a new object has arrived" inObjectData _ inBuf copyFrom: (inBufIndex + 4) to: (inBufIndex + 3 + self nextObjectLength). inBufIndex := inBufIndex + 4 + self nextObjectLength. inObjects addLast: (RWBinaryOrTextStream with: inObjectData) reset fileInObjectAndCode ]. self shrinkInBuf.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:57'! addDirectory: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromDirectory: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addFile: aFileName as: anotherFileName | newMember | newMember _ self memberClass newFromFile: aFileName. self addMember: newMember. newMember localFileName: anotherFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 15:03'! addString: aString as: aFileName | newMember | newMember _ self memberClass newFromString: aString named: aFileName. self addMember: newMember. newMember localFileName: aFileName. ^newMember! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:22'! addTree: aFileNameOrDirectory match: aBlock | nameSize | nameSize := aFileNameOrDirectory isString ifTrue: [aFileNameOrDirectory size] ifFalse: [aFileNameOrDirectory pathName size]. ^ self addTree: aFileNameOrDirectory removingFirstCharacters: nameSize + 1 match: aBlock! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/2/2005 13:00'! addTree: aFileNameOrDirectory removingFirstCharacters: n ^ self addTree: aFileNameOrDirectory removingFirstCharacters: n match: [:e | true]! ! !Archive methodsFor: 'archive operations' stamp: 'tak 2/15/2005 11:27'! addTree: aFileNameOrDirectory removingFirstCharacters: n match: aBlock | dir newMember fullPath relativePath | dir _ (aFileNameOrDirectory isString) ifTrue: [ FileDirectory on: aFileNameOrDirectory ] ifFalse: [ aFileNameOrDirectory ]. fullPath _ dir pathName, dir slash. relativePath _ fullPath copyFrom: n + 1 to: fullPath size. (dir entries select: [ :entry | aBlock value: entry]) do: [ :ea | | fullName | fullName _ fullPath, ea name. newMember _ ea isDirectory ifTrue: [ self memberClass newFromDirectory: fullName ] ifFalse: [ self memberClass newFromFile: fullName ]. newMember localFileName: relativePath, ea name. self addMember: newMember. ea isDirectory ifTrue: [ self addTree: fullName removingFirstCharacters: n match: aBlock]. ]. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:12'! canWriteToFileNamed: aFileName "Catch attempts to overwrite existing zip file" ^(members anySatisfy: [ :ea | ea usesFileNamed: aFileName ]) not. ! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! contentsOf: aMemberOrName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMember: aMemberOrName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: member localFileName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'nk 11/11/2002 14:09'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileDirectory default.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:48'! extractMemberWithoutPath: aMemberOrName inDirectory: dir | member | member _ self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: (FileDirectory localNameFor: member localFileName) inDirectory: dir! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! memberNamed: aString "Return the first member whose zip name or local file name matches aString, or nil" ^members detect: [ :ea | ea fileName = aString or: [ ea localFileName = aString ]] ifNone: [ ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !Archive methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:50'! membersMatching: aString ^members select: [ :ea | (aString match: ea fileName) or: [ aString match: ea localFileName ] ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! removeMember: aMemberOrName | member | member _ self member: aMemberOrName. member ifNotNil: [ members remove: member ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 07:57'! replaceMember: aMemberOrName with: newMember | member | member _ self member: aMemberOrName. member ifNotNil: [ members replaceAll: member with: newMember ]. ^member! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 17:24'! setContentsOf: aMemberOrName to: aString | newMember oldMember | oldMember _ self member: aMemberOrName. newMember _ (self memberClass newFromString: aString named: oldMember fileName) copyFrom: oldMember. self replaceMember: oldMember with: newMember.! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/24/2001 14:15'! writeToFileNamed: aFileName | stream | "Catch attempts to overwrite existing zip file" (self canWriteToFileNamed: aFileName) ifFalse: [ ^self error: (aFileName, ' is needed by one or more members in this archive') ]. stream _ StandardFileStream forceNewFileNamed: aFileName. self writeTo: stream. stream close.! ! !Archive methodsFor: 'initialization' stamp: 'nk 2/21/2001 17:58'! initialize members _ OrderedCollection new.! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! !Archive commentStamp: '' prior: 0! This is the abstract superclass for file archives. Archives can be read from or written to files, and contain members that represent files and directories.! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName ^fileName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 2/22/2001 16:00'! fileName: aName fileName _ aName! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt _ false ]! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 12/20/2002 15:02'! localFileName: aString "Set my internal filename. Returns the (possibly new) filename. aString will be translated from local FS format into Unix format." ^fileName _ aString copyReplaceAll: FileDirectory slash with: '/'.! ! !ArchiveMember methodsFor: 'testing' stamp: 'nk 2/21/2001 19:43'! usesFileNamed: aFileName "Do I require aFileName? That is, do I care if it's clobbered?" ^false! ! !ArchiveMember methodsFor: 'initialization' stamp: 'ar 3/2/2001 18:46'! close ! ! !ArchiveMember methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:05'! initialize fileName _ ''. isCorrupt _ false.! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !ArchiveMember commentStamp: '' prior: 0! This is the abstract superclass for archive members, which are files or directories stored in archives.! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromFile: aFileName self subclassResponsibility! ! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:32'! newFromString: aString self subclassResponsibility! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'! archive ^archive! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:36'! directory "For compatibility with file list." ^self error: 'should use readOnlyStream instead!!'! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:03'! fileName ^fileName! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:53'! fullName "For compatibility with FileList services. If this is called, it means that a service that requires a real filename has been requested. So extract the selected member to a temporary file and return that name." | fullName dir | self canExtractMember ifFalse: [ ^nil ]. dir _ FileDirectory default directoryNamed: '.archiveViewerTemp'. fullName _ dir fullNameFor: self selectedMember localFileName. self selectedMember extractInDirectory: dir. ^fullName! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 14:56'! members ^archive ifNil: [ #() asOrderedCollection ] ifNotNil: [ archive members asOrderedCollection ]! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 4/29/2004 10:39'! readOnlyStream "Answer a read-only stream on the selected member. For the various stream-reading services." ^self selectedMember ifNotNilDo: [ :mem | mem contentStream ascii ]! ! !ArchiveViewer methodsFor: 'accessing' stamp: 'nk 2/24/2001 11:17'! selectedMember ^memberIndex ifNil: [ nil ] ifNotNil: [ self members at: memberIndex ifAbsent: [ ] ]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:54'! canCreateNewArchive ^true! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'dgd 2/21/2003 22:36'! canExtractAll ^self members notEmpty! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 11:12'! canOpenNewArchive ^true! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:55'! canSaveArchive ^archive notNil! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:49'! commentArchive | newName | archive ifNil: [ ^self ]. newName _ FillInTheBlankMorph request: 'New comment for archive:' initialAnswer: archive zipFileComment centerAt: Sensor cursorPoint inWorld: self world onCancelReturn: archive zipFileComment acceptOnCR: true. archive zipFileComment: newName.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 23:29'! createNewArchive self setLabel: '(new archive)'. archive _ ZipArchive new. self memberIndex: 0. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'ar 2/6/2004 13:20'! extractAll | directory | self canExtractAll ifFalse: [^ self]. directory _ FileList2 modalFolderSelector ifNil: [^ self]. archive extractAllTo: directory.! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 12/20/2002 14:51'! extractAllPossibleInDirectory: directory "Answer true if I can extract all the files in the given directory safely. Inform the user as to problems." | conflicts | self canExtractAll ifFalse: [ ^false ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory fullNameFor: ea localFileName. (ea usesFileNamed: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) are needed by archive members and cannot be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. self inform: str contents. ^false. ]. conflicts _ Set new. self members do: [ :ea | | fullName | fullName _ directory relativeNameFor: ea localFileName. (directory fileExists: fullName) ifTrue: [ conflicts add: fullName ]. ]. conflicts notEmpty ifTrue: [ | str | str _ WriteStream on: (String new: 200). str nextPutAll: 'The following file(s) will be overwritten:'; cr. conflicts do: [ :ea | str nextPutAll: ea ] separatedBy: [ str cr ]. str cr; nextPutAll: 'Is this OK?'. ^PopUpMenu confirm: str contents. ]. ^true. ! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:14'! extractDirectoriesIntoDirectory: directory (self members select: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 11/11/2002 22:13'! extractFilesIntoDirectory: directory (self members reject: [:ea | ea isDirectory]) do: [:ea | ea extractInDirectory: directory]! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 2/24/2001 13:27'! openNewArchive | menu result | menu _ StandardFileMenu oldFileMenu: (FileDirectory default) withPattern: '*.zip'. result := menu startUpWithCaption: 'Select Zip archive to open...'. result ifNil: [ ^self ]. self fileName: (result directory fullNameFor: result name). ! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 4/19/2002 09:08'! saveArchive | result name | self canSaveArchive ifFalse: [ ^self ]. result _ StandardFileMenu newFile. result ifNil: [ ^self ]. name _ result directory fullNameFor: result name. (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try writing to another file name'. ^self ]. [ archive writeToFileNamed: name ] on: Error do: [ :ex | self inform: ex description. ]. self setLabel: name asString. self changed: #memberList "in case CRC's and compressed sizes got set"! ! !ArchiveViewer methodsFor: 'archive operations' stamp: 'nk 3/27/2002 12:57'! writePrependingFile | result name prependedName | self canSaveArchive ifFalse: [ ^self ]. result _ (StandardFileMenu newFileMenu: FileDirectory default) startUpWithCaption: 'Destination Zip File Name:'. result ifNil: [ ^self ]. name _ result directory fullNameFor: result name. (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try writing to another file name'. ^self ]. result _ (StandardFileMenu oldFileMenu: FileDirectory default) startUpWithCaption: 'Prepended File:'. result ifNil: [ ^self ]. prependedName _ result directory fullNameFor: result name. [ archive writeToFileNamed: name prependingFileNamed: prependedName ] on: Error do: [ :ex | self inform: ex description. ]. self changed: #memberList "in case CRC's and compressed sizes got set"! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:16'! archive: aZipArchive archive _ aZipArchive. self model: aZipArchive. self setLabel: 'New Zip Archive'. self memberIndex: 0. self changed: #memberList! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:43'! briefContents "Trim to 5000 characters. If the member is longer, then point out that it is trimmed. Also warn if the member has a corrupt CRC-32." | stream subContents errorMessage | self selectedMember ifNil: [^ '']. errorMessage _ ''. stream _ WriteStream on: (String new: (self selectedMember uncompressedSize min: 5500)). [ self selectedMember uncompressedSize > 5000 ifTrue: [ | lastLineEndingIndex tempIndex | subContents _ self selectedMember contentsFrom: 1 to: 5000. lastLineEndingIndex _ subContents lastIndexOf: Character cr. tempIndex _ subContents lastIndexOf: Character lf. tempIndex > lastLineEndingIndex ifTrue: [lastLineEndingIndex _ tempIndex]. lastLineEndingIndex = 0 ifFalse: [subContents _ subContents copyFrom: 1 to: lastLineEndingIndex]] ifFalse: [ subContents _ self selectedMember contents ]] on: CRCError do: [ :ex | errorMessage _ String streamContents: [ :s | s nextPutAll: '[ '; nextPutAll: (ex messageText copyUpToLast: $( ); nextPutAll: ' ]' ]. ex proceed ]. (errorMessage isEmpty not or: [ self selectedMember isCorrupt ]) ifTrue: [ stream nextPutAll: '********** WARNING!! Member is corrupt!! '; nextPutAll: errorMessage; nextPutAll: ' **********'; cr ]. self selectedMember uncompressedSize > 5000 ifTrue: [ stream nextPutAll: 'File '; print: self selectedMember fileName; nextPutAll: ' is '; print: self selectedMember uncompressedSize; nextPutAll: ' bytes long.'; cr; nextPutAll: 'Click the ''View All Contents'' button above to see the entire file.'; cr; cr; nextPutAll: 'Here are the first '; print: subContents size; nextPutAll: ' characters...'; cr; next: 40 put: $-; cr; nextPutAll: subContents; next: 40 put: $-; cr; nextPutAll: '... end of the first '; print: subContents size; nextPutAll: ' characters.' ] ifFalse: [ stream nextPutAll: self selectedMember contents ]. ^stream contents ! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:58'! buttonColor ^self defaultBackgroundColor darker! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'! buttonOffColor ^self defaultBackgroundColor darker! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'! buttonOnColor ^self defaultBackgroundColor! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 3/7/2004 16:45'! contents | contents errorMessage | self selectedMember ifNil: [^ '']. viewAllContents ifFalse: [^ self briefContents]. [ contents _ self selectedMember contents ] on: CRCError do: [ :ex | errorMessage _ String streamContents: [ :stream | stream nextPutAll: '********** WARNING!! Member is corrupt!! [ '; nextPutAll: (ex messageText copyUpToLast: $( ); nextPutAll: '] **********'; cr ]. ex proceed ]. ^self selectedMember isCorrupt ifFalse: [ contents ] ifTrue: [ errorMessage, contents ]! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/25/2001 00:04'! contents: aText self shouldNotImplement.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'kfr 9/22/2004 21:19'! createButtonBar | bar button narrowFont registeredFonts | registeredFonts _ OrderedCollection new. TextStyle knownTextStylesWithoutDefault do: [:st | (TextStyle named: st) fonts do: [:f | registeredFonts addLast: f]]. narrowFont := registeredFonts detectMin: [:ea | ea widthOfString: 'Contents' from: 1 to: 8]. bar := AlignmentMorph newRow. bar color: self defaultBackgroundColor; rubberBandCells: false; vResizing: #shrinkWrap; cellInset: 6 @ 0. #(#('New\Archive' #canCreateNewArchive #createNewArchive 'Create a new, empty archive and discard this one') #('Load\Archive' #canOpenNewArchive #openNewArchive 'Open another archive and discard this one') #('Save\Archive As' #canSaveArchive #saveArchive 'Save this archive under a new name') #('Extract\All' #canExtractAll #extractAll 'Extract all this archive''s members into a directory') #('Add\File' #canAddMember #addMember 'Add a file to this archive') #('Add from\Clipboard' #canAddMember #addMemberFromClipboard 'Add the contents of the clipboard as a new file') #('Add\Directory' #canAddMember #addDirectory 'Add the entire contents of a directory, with all of its subdirectories') #('Extract\Member As' #canExtractMember #extractMember 'Extract the selected member to a file') #('Delete\Member' #canDeleteMember #deleteMember 'Remove the selected member from this archive') #('Rename\Member' #canRenameMember #renameMember 'Rename the selected member') #('View All\Contents' #canViewAllContents #changeViewAllContents 'Toggle the view of all the selected member''s contents')) do: [:arr | | buttonLabel | buttonLabel := (TextMorph new) string: arr first withCRs fontName: narrowFont familyName size: narrowFont pointSize wrap: false; hResizing: #shrinkWrap; lock; yourself. (button := PluggableButtonMorph on: self getState: arr second action: arr third) vResizing: #shrinkWrap; hResizing: #spaceFill; onColor: self buttonOnColor offColor: self buttonOffColor; label: buttonLabel; setBalloonText: arr fourth. bar addMorphBack: button. buttonLabel composeToBounds]. ^bar! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'! createListHeadingUsingFont: font | sm | sm _ StringMorph contents: ' uncomp comp CRC-32 date time file name'. font ifNotNil: [ sm font: font ]. ^(AlignmentMorph newColumn) color: self defaultBackgroundColor; addMorph: sm; yourself.! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:59'! createWindow | list heading font text buttonBar | font _ (TextStyle named: #DefaultFixedTextStyle) ifNotNilDo: [ :ts | ts fontArray first]. buttonBar _ self createButtonBar. self addMorph: buttonBar fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@0 corner: 0@44)). self minimumExtent: (buttonBar fullBounds width + 20) @ 230. self extent: self minimumExtent. heading _ self createListHeadingUsingFont: font. self addMorph: heading fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.0) offsets: (0@44 corner: 0@60)). (list _ PluggableListMorph new) on: self list: #memberList selected: #memberIndex changeSelected: #memberIndex: menu: #memberMenu:shifted: keystroke: nil. list color: self defaultBackgroundColor. font ifNotNil: [list font: font]. self addMorph: list fullFrame: (LayoutFrame fractions: (0@0 corner: 1.0@0.8) offsets: (0@60 corner: 0@0)). text _ PluggableTextMorph on: self text: #contents accept: nil readSelection: nil menu: nil. self addMorph: text frame: (0@0.8 corner: 1.0@1.0). text lock. self setLabel: 'Ned''s Zip Viewer'! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 2/24/2001 23:28'! fileName: aString archive _ ZipArchive new readFrom: aString. self setLabel: aString. self memberIndex: 0. self changed: #memberList! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:16'! initialize super initialize. memberIndex _ 0. viewAllContents _ false. ! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:29'! stream: aStream archive _ ZipArchive new readFrom: aStream. self setLabel: aStream fullName. self memberIndex: 0. self changed: #memberList! ! !ArchiveViewer methodsFor: 'initialization' stamp: 'nk 6/10/2004 08:15'! windowIsClosing archive ifNotNil: [ archive close ].! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 22:32'! displayLineFor: aMember | stream dateTime | stream _ WriteStream on: (String new: 60). dateTime _ Time dateAndTimeFromSeconds: aMember lastModTime. stream nextPutAll: (aMember uncompressedSize printString padded: #left to: 8 with: $ ); space; nextPutAll: (aMember compressedSize printString padded: #left to: 8 with: $ ); space; space; nextPutAll: (aMember crc32String ); space; space. dateTime first printOn: stream format: #(3 2 1 $- 2 1 2). stream space. dateTime second print24: true showSeconds: false on: stream. stream space; space; nextPutAll: (aMember fileName ). ^stream contents! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/23/2001 22:48'! highlightMemberList: list with: morphList (morphList at: self memberIndex) color: Color red! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 09:40'! memberIndex ^memberIndex! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 23:46'! memberIndex: n memberIndex _ n. viewAllContents _ false. self changed: #memberIndex. self changed: #contents.! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 2/24/2001 11:51'! memberList ^ self members collect: [ :ea | self displayLineFor: ea ]! ! !ArchiveViewer methodsFor: 'member list' stamp: 'nk 4/29/2004 10:20'! memberMenu: menu shifted: shifted | services | menu add: 'Comment archive' target: self selector: #commentArchive; balloonTextForLastItem: 'Add a comment for the entire archive'. self selectedMember ifNotNilDo: [ :member | menu addLine; add: 'Inspect member' target: self selector: #inspectMember; balloonTextForLastItem: 'Inspect the selected member'; add: 'Comment member' target: self selector: #commentMember; balloonTextForLastItem: 'Add a comment for the selected member'; addLine. services _ FileList itemsForFile: member fileName. menu addServices2: services for: self extraLines: #(). ]. ^menu! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:28'! addDirectory | directory | self canAddMember ifFalse: [ ^self ]. directory _ FileList2 modalFolderSelector. directory ifNil: [^ self]. archive addTree: directory removingFirstCharacters: directory pathName size + 1. self memberIndex: 0. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:26'! addMember | result relative | self canAddMember ifFalse: [ ^self ]. result _ StandardFileMenu oldFile. result ifNil: [ ^self ]. relative _ result directory fullNameFor: result name. (relative beginsWith: FileDirectory default pathName) ifTrue: [ relative _ relative copyFrom: FileDirectory default pathName size + 2 to: relative size ]. (archive addFile: relative) desiredCompressionMethod: ZipArchive compressionDeflated. self memberIndex: self members size. self changed: #memberList.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'! addMemberFromClipboard | string newName | self canAddMember ifFalse: [ ^self ]. string _ Clipboard clipboardText asString. newName _ FillInTheBlankMorph request: 'New name for member:' initialAnswer: 'clipboardText'. newName notEmpty ifTrue: [ (archive addString: string as: newName) desiredCompressionMethod: ZipArchive compressionDeflated. self memberIndex: self members size. self changed: #memberList. ] ! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:50'! canAddMember ^archive notNil! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canDeleteMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canExtractMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 11:02'! canRenameMember ^memberIndex > 0! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:50'! canViewAllContents ^memberIndex > 0 and: [ viewAllContents not ]! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 3/7/2004 16:47'! changeViewAllContents (viewAllContents not and: [ self selectedMember notNil and: [ self selectedMember uncompressedSize > 50000 ]]) ifTrue: [ (PopUpMenu confirm: 'This member''s size is ', (self selectedMember uncompressedSize asString), '; do you really want to see all that data?') ifFalse: [ ^self ] ]. viewAllContents _ viewAllContents not. self changed: #contents! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:50'! commentMember | newName | newName _ FillInTheBlankMorph request: 'New comment for member:' initialAnswer: self selectedMember fileComment centerAt: Sensor cursorPoint inWorld: self world onCancelReturn: self selectedMember fileComment acceptOnCR: true. self selectedMember fileComment: newName.! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 23:29'! deleteMember self canDeleteMember ifFalse: [ ^self ]. archive removeMember: self selectedMember. self memberIndex: 0. self changed: #memberList. ! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 4/29/2004 10:46'! extractMember "Extract the member after prompting for a filename. Answer the filename, or nil if error." | result name | self canExtractMember ifFalse: [ ^nil ]. result _ StandardFileMenu newFile. result ifNil: [ ^nil ]. name _ (result directory fullNameFor: result name). (archive canWriteToFileNamed: name) ifFalse: [ self inform: name, ' is used by one or more members in your archive, and cannot be overwritten. Try extracting to another file name'. ^nil ]. self selectedMember extractToFileNamed: name. ^name! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 13:01'! inspectMember self selectedMember inspect! ! !ArchiveViewer methodsFor: 'member operations' stamp: 'nk 2/24/2001 14:53'! renameMember | newName | self canRenameMember ifFalse: [ ^self ]. newName _ FillInTheBlankMorph request: 'New name for member:' initialAnswer: self selectedMember fileName. newName notEmpty ifTrue: [ self selectedMember fileName: newName. self changed: #memberList ]! ! !ArchiveViewer methodsFor: 'menu' stamp: 'nk 3/27/2002 12:48'! buildWindowMenu | menu | menu _ super buildWindowMenu. menu addLine. menu add: 'inspect archive' target: archive action: #inspect. menu add: 'write prepending file...' target: self action: #writePrependingFile. ^menu.! ! !ArchiveViewer methodsFor: 'message handling' stamp: 'nk 2/24/2001 13:16'! perform: selector orSendTo: otherTarget ^ self perform: selector! ! !ArchiveViewer methodsFor: 'parts bin' stamp: 'dls 10/22/2001 07:40'! initializeToStandAlone self initialize createWindow.! ! !ArchiveViewer commentStamp: '' prior: 0! This is a viewer window that allows editing and viewing of Zip archives.! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:05'! deleteTemporaryDirectory " ArchiveViewer deleteTemporaryDirectory " | dir | (dir _ self temporaryDirectory) exists ifTrue: [ dir recursiveDelete ].! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 10:56'! initialize "ArchiveViewer initialize" FileList registerFileReader: self. Smalltalk addToShutDownList: self.! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:35'! serviceOpenInZipViewer "Answer a service for opening in a zip viewer" ^ SimpleServiceEntry provider: self label: 'open in zip viewer' selector: #openOn: description: 'open in zip viewer' buttonLabel: 'open zip'! ! !ArchiveViewer class methodsFor: 'class initialization' stamp: 'nk 4/29/2004 11:06'! shutDown: quitting quitting ifTrue: [ self deleteTemporaryDirectory ].! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:46'! extractAllFrom: aFileName (self new) fileName: aFileName; extractAll! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:48'! serviceAddToNewZip "Answer a service for adding the file to a new zip" ^ FileModifyingSimpleServiceEntry provider: self label: 'add file to new zip' selector: #addFileToNewZip: description: 'add file to new zip' buttonLabel: 'to new zip'! ! !ArchiveViewer class methodsFor: 'file list services' stamp: 'nk 11/26/2002 12:15'! serviceExtractAll "Answer a service for opening in a zip viewer" ^ FileModifyingSimpleServiceEntry provider: self label: 'extract all to...' selector: #extractAllFrom: description: 'extract all files to a user-specified directory' buttonLabel: 'extract all'! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 8/21/2004 16:01'! fileReaderServicesForFile: fullName suffix: suffix | services | services _ OrderedCollection new. services add: self serviceAddToNewZip. ({'zip'.'sar'.'pr'. 'mcz'. '*'} includes: suffix) ifTrue: [services add: self serviceOpenInZipViewer. services add: self serviceExtractAll]. ^ services! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:18'! services ^ Array with: self serviceAddToNewZip with: self serviceOpenInZipViewer ! ! !ArchiveViewer class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:56'! temporaryDirectory "Answer a directory to use for unpacking files for the file list services." ^FileDirectory default directoryNamed: '.archiveViewerTemp'! ! !ArchiveViewer class methodsFor: 'initialize-release' stamp: 'nk 1/30/2002 10:13'! unload FileList unregisterFileReader: self ! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 1/30/2002 10:18'! addFileToNewZip: fullName "Add the currently selected file to a new zip" | zip | zip := (ZipArchive new) addFile: fullName as: (FileDirectory localNameFor: fullName); yourself. (self open) archive: zip ! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 2/23/2001 21:52'! open ^(self new) createWindow; openInWorld.! ! !ArchiveViewer class methodsFor: 'instance creation' stamp: 'nk 11/26/2002 12:45'! openOn: aFileName | newMe | newMe _ self new. newMe createWindow; fileName: aFileName; openInWorld. ^newMe! ! !ArchiveViewer class methodsFor: 'parts bin' stamp: 'nk 3/27/2002 11:41'! descriptionForPartsBin ^ self partName: 'Zip Tool' categories: #(Tools) documentation: 'A viewer and editor for Zip archive files' ! ! !Array methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:03'! literalEqual: other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. self with: other do: [:e1 :e2 | (e1 literalEqual: e2) ifFalse: [^ false]]. ^ true! ! !Array methodsFor: 'converting' stamp: 'tpr 11/2/2004 11:31'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." otherArray class == Array ifFalse: [^ self error: 'arg must be array']. self size = otherArray size ifFalse: [^ self error: 'arrays must be same size']. (self anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. (otherArray anySatisfy: [:obj | obj class == SmallInteger]) ifTrue: [^ self error: 'can''t become SmallIntegers']. self with: otherArray do:[:a :b| a == b ifTrue:[^self error:'can''t become yourself']]. "Must have failed because not enough space in forwarding table (see ObjectMemory-prepareForwardingTableForBecoming:with:twoWay:). Do GC and try again only once" (Smalltalk bytesLeft: true) = Smalltalk primitiveGarbageCollect ifTrue: [^ self primitiveFailed]. ^ self elementsExchangeIdentityWith: otherArray! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'brp 9/26/2003 08:09'! elementsForwardIdentityTo: otherArray copyHash: copyHash "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'yo 9/2/2002 18:23'! evalStrings "Allows you to construct literal arrays. #(true false nil '5@6' 'Set new' '''text string''') evalStrings gives an array with true, false, nil, a Point, a Set, and a String instead of just a bunch of Symbols" | it | ^ self collect: [:each | it _ each. each == #true ifTrue: [it _ true]. each == #false ifTrue: [it _ false]. each == #nil ifTrue: [it _ nil]. ((each class == String) or: [each class == MultiString]) ifTrue: [ it _ Compiler evaluate: each]. each class == Array ifTrue: [it _ it evalStrings]. it]! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:02'! atWrap: index "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1! ! !Array methodsFor: 'accessing' stamp: 'ar 8/26/2001 22:03'! atWrap: index put: anObject "Optimized to go through the primitive if possible" ^ self at: index - 1 \\ self size + 1 put: anObject! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:09'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByArray: self ! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:10'! preMultiplyByArray: a "Answer a+*self where a is an Array. Arrays are always understood as column vectors, so an n element Array is an n*1 Array. This multiplication is legal iff self size = 1." self size = 1 ifFalse: [self error: 'dimensions do not conform']. ^a * self first! ! !Array methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:08'! preMultiplyByMatrix: m "Answer m+*self where m is a Matrix." |s| m columnCount = self size ifFalse: [self error: 'dimensions do not conform']. ^(1 to: m rowCount) collect: [:row | s _ 0. 1 to: self size do: [:k | s _ (m at: row at: k) * (self at: k) + s]. s]! ! !Array class methodsFor: 'instance creation' stamp: 'md 7/19/2004 12:34'! new: sizeRequested "Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. This is a shortcut (direct call of primitive, no #initialize, for performance" "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !ArrayLiteralTest methodsFor: 'as yet unclassified' stamp: 'avi 2/16/2004 21:09'! testSymbols self class compile: 'array ^ #(#nil #true #false #''nil'' #''true'' #''false'')'. self assert: self array = {#nil. #true. #false. #nil. #true. #false}.! ! !ArrayTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:29'! setUp example1 := #(1 2 3 4 5).! ! !ArrayTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:36'! testIsLiteral self assert: example1 isLiteral. example1 at: 1 put: self class. self deny: example1 isLiteral. example1 at: 1 put: 1.! ! !ArrayTest commentStamp: '' prior: 0! This is the unit test for the class Array. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:28'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 18:51'! bytesPerElement ^self class isBytes ifTrue: [ 1 ] ifFalse: [ 4 ]. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 7/30/2004 17:50'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^self]. SmalltalkImage current isLittleEndian ifTrue: [Bitmap swapBytesIn: self from: 1 to: self basicSize]! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'md 12/12/2003 17:01'! swapBytesFrom: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | self deprecated: 'Use BitMap class>>swapBytesIn:from:to:'. self class isPointers | self class isWords not ifTrue: [^ self]. "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 17:36'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word. This method is only used for 16-bit quanities in SoundBuffer, ShortIntegerArray, etc." | hack blt | "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'ar 5/17/2001 19:50'! writeOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds. We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOn: aStream]. "super may cause an error, but will not be called." aStream nextInt32Put: self basicSize. aStream nextWordsPutAll: self.! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'tk 3/7/2001 18:07'! writeOnGZIPByteStream: aStream "We only intend this for non-pointer arrays. Do nothing if I contain pointers." self class isPointers | self class isWords not ifTrue: [^ super writeOnGZIPByteStream: aStream]. "super may cause an error, but will not be called." aStream nextPutAllWordArray: self! ! !ArrayedCollection commentStamp: '' prior: 0! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'ar 5/17/2001 19:50'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." | len | self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. "super may cause an error, but will not be called." s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len _ s nextInt32. ^ s nextWordsInto: (self basicNew: len)! ! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! !AssignmentNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 21:17'! variable: aVariable value: expression from: encoder sourceRange: range encoder noteSourceRange: range forNode: self. ^self variable: aVariable value: expression from: encoder! ! !AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 18:46'! emitForEffect: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. variable emitStorePop: stack on: aStream. pc _ aStream position! ! !AssignmentNode methodsFor: 'code generation' stamp: 'di 9/5/2001 21:26'! emitForValue: stack on: aStream variable emitLoad: stack on: aStream. value emitForValue: stack on: aStream. variable emitStore: stack on: aStream. pc _ aStream position! ! !AssignmentNode methodsFor: 'printing' stamp: 'brp 10/8/2003 14:55'! printOn: aStream indent: level aStream dialect = #SQ00 ifTrue: [aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: 'Set ']. variable printOn: aStream indent: level. aStream withStyleFor: #setOrReturn do: [aStream nextPutAll: ' to ']. value printOn: aStream indent: level + 2] ifFalse: [variable printOn: aStream indent: level. aStream nextPutAll: (Preferences ansiAssignmentOperatorWhenPrettyPrinting ifTrue: [' := '] ifFalse: [' _ ']). value printOn: aStream indent: level + 2]! ! !AssignmentNode methodsFor: 'tiles' stamp: 'RAA 2/26/2001 16:17'! asMorphicSyntaxIn: parent ^parent assignmentNode: self variable: variable value: value! ! !AssignmentTileMorph methodsFor: 'arrow' stamp: 'nk 10/8/2004 14:27'! addArrowsIfAppropriate "If the receiver's slot is of an appropriate type, add arrows to the tile." (Vocabulary vocabularyForType: dataType) ifNotNilDo: [:aVocab | aVocab wantsAssignmentTileVariants ifTrue: [self addArrows]]. (assignmentSuffix = ':') ifTrue: [ self addMorphBack: (ImageMorph new image: (ScriptingSystem formAtKey: #NewGets)). (self findA: StringMorph) ifNotNilDo: [ :sm | (sm contents endsWith: ' :') ifTrue: [ sm contents: (sm contents allButLast: 2) ]]]! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:17'! assignmentReceiverTile "Answer the TilePadMorph that should be sent storeCodeOn:indent: to get the receiver of the assignment properly stored on the code stream" ^ owner submorphs first! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'sw 2/6/2002 01:25'! operatorForAssignmentSuffix: aString "Answer the operator associated with the receiver, assumed to be one of the compound assignments" | toTest | toTest _ aString asString. #( ('Incr:' '+') ('Decr:' '-') ('Mult:' '*')) do: [:pair | toTest = pair first ifTrue: [^ pair second]]. ^ toTest "AssignmentTileMorph new operatorForAssignmentSuffix: 'Incr:'"! ! !AssignmentTileMorph methodsFor: 'code generation' stamp: 'aoy 2/15/2003 21:09'! storeCodeOn: aStream indent: tabCount "Generate code for an assignment statement. The code generated looks presentable in the case of simple assignment, though the code generated for the increment/decrement/multiply cases is still the same old assignGetter... sort for now" aStream nextPutAll: (Utilities setterSelectorFor: assignmentRoot). aStream space."Simple assignment, don't need existing value" assignmentSuffix = ':' ifFalse: ["Assignments that require that old values be retrieved" self assignmentReceiverTile storeCodeOn: aStream indent: tabCount. aStream space. aStream nextPutAll: (Utilities getterSelectorFor: assignmentRoot). aStream space. aStream nextPutAll: (self operatorForAssignmentSuffix: assignmentSuffix). aStream space]! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'mir 7/12/2004 20:22'! computeOperatorOrExpression "Compute the operator or expression to use, and set the wording correectly on the tile face" | aSuffix wording anInterface getter doc | operatorOrExpression _ (assignmentRoot, assignmentSuffix) asSymbol. aSuffix _ self currentVocabulary translatedWordingFor: assignmentSuffix. getter _ Utilities getterSelectorFor: assignmentRoot. anInterface _ self currentVocabulary methodInterfaceAt: getter ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [nil]]. wording _ anInterface ifNotNil: [anInterface wording] ifNil: [assignmentRoot copyWithout: $:]. (anInterface notNil and: [(doc _ anInterface documentation) notNil]) ifTrue: [self setBalloonText: doc]. operatorReadoutString _ wording, ' ', aSuffix. self line1: operatorReadoutString. self addArrowsIfAppropriate! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'! initialize "initialize the state of the receiver" super initialize. "" type _ #operator. assignmentSuffix _ ':'! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'yo 1/1/2004 19:50'! setRoot: aString "Establish the assignment root, and update the label on the tile" assignmentRoot _ aString. self updateLiteralLabel! ! !AssignmentTileMorph methodsFor: 'initialization' stamp: 'sw 9/12/2001 22:52'! updateWordingToMatchVocabulary "The current vocabulary has changed; change the wording on my face, if appropriate" self computeOperatorOrExpression! ! !AssignmentTileMorph methodsFor: 'player viewer' stamp: 'yo 1/1/2004 19:51'! assignmentRoot "Answer the assignment root" ^ assignmentRoot! ! !AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:04'! options ^ {#(#: #Incr: #Decr: #Mult: ). {nil. nil. nil. nil}}! ! !AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:09'! value ^ assignmentSuffix! ! !AssignmentTileMorph methodsFor: 'accessing' stamp: 'tak 12/5/2004 14:06'! value: anObject self setAssignmentSuffix: anObject. self acceptNewLiteral! ! !AssignmentTileMorph methodsFor: 'as yet unclassified'! fixLayoutOfSubmorphsNotIn: aCollection super fixLayoutOfSubmorphsNotIn: aCollection. self updateLiteralLabel; updateWordingToMatchVocabulary; layoutChanged; fullBounds! ! !Association methodsFor: 'testing' stamp: 'ar 8/14/2001 23:06'! isSpecialWriteBinding "Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages" ^false! ! !Association methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'! isVariableBinding "Return true if I represent a literal variable binding" ^true! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:28'! hash "Hash is reimplemented because = is implemented." ^key hash bitXor: value hash.! ! !AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:37'! testEquality self assert: (a key = b key); deny: (a value = b value); deny: (a = b) ! ! !AssociationTest methodsFor: 'testing' stamp: 'md 3/8/2004 16:38'! testHash self assert: (a hash = a copy hash); deny: (a hash = b hash)! ! !AssociationTest methodsFor: 'setup' stamp: 'md 3/8/2004 16:37'! setUp a _ 1 -> 'one'. b _ 1 -> 'een'.! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'JMM 11/24/2001 17:23'! test: byteCount fileName: fileName "AsyncFile new test: 10000 fileName: 'testData'" | buf1 buf2 bytesWritten bytesRead | buf1 _ String new: byteCount withAll: $x. buf2 _ String new: byteCount. self open: ( FileDirectory default fullNameFor: fileName) forWrite: true. self primWriteStart: fileHandle fPosition: 0 fromBuffer: buf1 at: 1 count: byteCount. semaphore wait. bytesWritten _ self primWriteResult: fileHandle. self close. self open: ( FileDirectory default fullNameFor: fileName) forWrite: false. self primReadStart: fileHandle fPosition: 0 count: byteCount. semaphore wait. bytesRead _ self primReadResult: fileHandle intoBuffer: buf2 at: 1 count: byteCount. self close. buf1 = buf2 ifFalse: [self error: 'buffers do not match']. ^ 'wrote ', bytesWritten printString, ' bytes; ', 'read ', bytesRead printString, ' bytes' ! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !AtomMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:13'! initialize "Make a new atom with a random position and velocity." super initialize. "" self extent: 8 @ 7. self randomPositionIn: (0 @ 0 corner: 300 @ 300) maxVelocity: 10! ! !AtomMorph commentStamp: 'tbn 11/25/2004 09:06' prior: 0! AtomMorph represents an atom used in the simulation of an ideal gas. It's container is typically a BouncingAtomsMorph. Try: BouncingAtomsMorph new openInWorld to open the gas simulation or: AtomMorph example to open an instance in the current world! !AtomMorph class methodsFor: 'examples' stamp: 'tbn 11/25/2004 09:03'! example " AtomMorph example " |a| a := AtomMorph new openInWorld. a color: Color random. [1000 timesRepeat: [a bounceIn: World bounds. (Delay forMilliseconds: 50) wait]. a delete] fork.! ! !AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'! setUp morph := AtomMorph new.! ! !AtomMorphTest methodsFor: 'initialize-release' stamp: 'md 4/17/2003 19:03'! tearDown morph delete.! ! !AtomMorphTest methodsFor: 'testing ' stamp: 'md 4/17/2003 19:06'! testVelocity morph velocity: 0@0. self assert: ( (morph velocity) = (0@0) ).! ! !AtomMorphTest commentStamp: '' prior: 0! This is the unit test for the class AtomMorph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'! description "Return a textual description of the exception." | desc mt | desc := 'Error'. ^(mt := self messageText) == nil ifTrue: [desc] ifFalse: [desc, ': ', mt]! ! !AttemptToWriteReadOnlyGlobal methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:02'! isResumable ^true! ! !AttemptToWriteReadOnlyGlobal commentStamp: 'gh 5/2/2002 20:26' prior: 0! This is a resumable error you get if you try to assign a readonly variable a value. Name definitions in the module system can be read only and are then created using instances of ReadOnlyVariableBinding instead of Association. See also LookupKey>>beReadWriteBinding and LookupKey>>beReadOnlyBinding. ! !AttributedTextStream methodsFor: 'retrieving the text' stamp: 'ar 10/16/2001 22:39'! contents | ans | currentRun > 0 ifTrue:[ attributeValues nextPut: currentAttributes. attributeRuns nextPut: currentRun. currentRun _ 0]. ans _ Text new: characters size. "this is declared private, but it's exactly what I need, and it's declared as exactly what I want it to do...." ans setString: characters contents setRuns: (RunArray runs: attributeRuns contents values: attributeValues contents). ^ans! ! !AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'! nextPut: aChar currentRun _ currentRun + 1. characters nextPut: aChar! ! !AttributedTextStream methodsFor: 'stream protocol' stamp: 'ar 10/16/2001 22:38'! nextPutAll: aString "add an entire string with the same attributes" currentRun _ currentRun + aString size. characters nextPutAll: aString.! ! !AttributedTextStream methodsFor: 'access' stamp: 'ar 10/16/2001 22:57'! currentAttributes: newAttributes "set the current attributes" (currentRun > 0 and:[currentAttributes ~= newAttributes]) ifTrue:[ attributeRuns nextPut: currentRun. attributeValues nextPut: currentAttributes. currentRun _ 0. ]. currentAttributes _ newAttributes. ! ! !AttributedTextStream methodsFor: 'private-initialization' stamp: 'ar 10/16/2001 22:40'! initialize characters _ WriteStream on: String new. currentAttributes _ OrderedCollection new. currentRun _ 0. attributeValues _ WriteStream on: (Array new: 50). attributeRuns _ WriteStream on: (Array new: 50). ! ! !AttributedTextStream class methodsFor: 'instance creation' stamp: 'gk 2/9/2004 18:50'! new "For this class we override Stream class>>new since this class actually is created using #new, even though it is a Stream." ^self basicNew initialize! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !AudioChatGUI methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:48'! initialize "initialize the state of the receiver" super initialize. "" transmitWhileRecording _ false. handsFreeTalking _ false. mycodec _ GSMCodec new. myrecorder _ ChatNotes new. mytargetip _ ''. self start2. self changeTalkButtonLabel! ! !AudioChatGUI methodsFor: 'stuff' stamp: 'aoy 2/17/2003 01:01'! changeTalkButtonLabel | bText | self transmitWhileRecording. handsFreeTalking ifTrue: [theTalkButton labelUp: 'Talk'; labelDown: 'Release'; label: 'Talk'. bText := 'Click once to begin a message. Click again to end the message.'] ifFalse: [theTalkButton labelUp: 'Talk'; labelDown: (transmitWhileRecording ifTrue: ['TALKING'] ifFalse: ['RECORDING']); label: 'Talk'. bText := 'Press and hold to record a message.']. bText := transmitWhileRecording ifTrue: [bText , ' The message will be sent while you are speaking.'] ifFalse: [bText , ' The message will be sent when you are finished.']. theTalkButton setBalloonText: bText! ! !AudioChatGUI class methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:35'! descriptionForPartsBin "Answer a description of the receiver for use in a parts bin" ^ self partName: 'Audio chat' categories: #('Collaborative') documentation: 'A tool for talking to other Squeak uers' sampleImageForm: (Form extent: 110@70 depth: 8 fromArray: #( 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193909241 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 3842048257 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 31843813 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783321061 31843813 3857048833 16901605 3842106625 31843813 3842106625 31843813 3842048257 3857049061 16901605 16843237 3857048960 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 31843813 3856990693 3856990693 16843237 3842106853 16843237 3842106853 31843813 31843585 3856990693 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3783321061 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 16843009 31785445 3857049061 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 31843813 3856990693 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 3856990693 3857049061 3842106853 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 31843813 31785445 3856990693 3842106853 3842106853 3842106853 3842106853 31843813 31843585 3856990693 3842106853 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783648741 3842048257 3857048833 16901605 16843237 16843237 16843237 16843237 3842048257 3857049061 16901605 3856990693 3857048965 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3783321061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857013729 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789653477 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857024481 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 2239817189 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857048960 2246173153 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789642629 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466373 1535466465 3789677025 3789619457 16842752 4177592577 31580641 3777552865 3789677025 3789677025 685891880 3789677025 3789677025 3789629665 3777552865 3789677025 3789677025 685892065 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3777505320 673720360 673720360 685891880 673720360 673720360 673720545 3777505320 673720360 673720360 685892065 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3842048257 16901605 16901605 3857049061 3857049061 3857049061 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 3857049061 3857049061 3857049061 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3856990693 3842106853 3842048257 3857048833 16901377 16901605 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3856990693 3842106853 31843813 31843813 31843813 31843813 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990465 16901605 3842106853 3842048257 31843813 3842106625 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3856990693 3857049061 3842106853 31843813 31843813 3842106625 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789642725 3856990693 3857049061 3842106853 31843813 31843813 3856990693 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789653477 3842048257 3857049061 16843237 3842048257 3842106853 3856990693 3857049061 3857024481 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16871572 1888776340 1895825407 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789642725 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3857013729 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3842106853 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783613413 3857049061 3857049061 3857049061 3857049061 3857049061 3857013637 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16880752 2490406000 4285568112 4285568112 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 2239792512 2239792512 2239792512 2239792512 2239792512 2239816161 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 31580641 31580641 16871572 1888776340 4287918228 4287918228 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3774939393 3789677025 16880752 2490406000 2499805183 2490406000 2490406000 2490405889 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 16871572 1888776340 1888776340 1888776340 1888776340 1888776193 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939504 2490406000 2490406000 2490406000 2490406000 2490368257 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3774939540 1888776340 1888776340 1888776340 1888776340 1888747777 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 2490406000 2490406000 2490406000 2490406000 2483093985 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3856990465 16843237 3857049061 3857048833 31843813 31843813 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789619457 26505364 1888776340 1888776340 1888776340 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3856990693 31785445 3857049061 3857049061 31843585 31843813 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789676801 16880752 2490406000 2490406000 2490405889 16900577 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 3857049061 31843813 31843585 31843813 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 16843009 1888776340 1888776340 1879113985 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789619457 16843009 16843009 16843233 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 3842048257 31843813 31843813 16901605 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 16843009 16843009 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857049061 31843813 31843813 31843813 31843813 31785445 3857049061 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 31843813 31843813 31843813 31843813 31843585 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676933 3857048833 16901605 3842048257 3842106625 16901377 16901377 31843813 3850756577 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789676928 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 3850428897 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1541793253 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 1541530081 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 2246436325 3857049061 3857049061 3857049061 3857049061 3857049061 3857049061 2246173153 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3783648741 3857049061 3857049061 3857049061 3857049061 3857049061 3857048965 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789653376 3857049061 3857049061 3857049061 3857049061 3857049061 3850405345 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 1535466373 1535466373 1535466373 1535466373 1535466373 1541530081 3789677025 3789677025 3789677025 3789619457 16842752 4177592577 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 16842752 4193845505 31580641 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789677025 3789619457 33095680 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33095680 4193908993 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 4193845248 4193909241 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843257 4193845248 4193909241 4193845505 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 16843009 33159673 4193845248) offset: 0@0)! ! !Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'ar 8/17/2001 18:19'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Squeak/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! !AutoStart class methodsFor: 'class initialization' stamp: 'mir 9/30/2004 15:05'! initialize "AutoStart initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: AutoStart after: SecurityManager. Smalltalk addToShutDownList: AutoStart after: SecurityManager.! ! !AutoStart class methodsFor: 'class initialization' stamp: 'mir 9/30/2004 15:06'! shutDown: quitting self active: false! ! !AutoStart class methodsFor: 'class initialization' stamp: 'bf 11/23/2004 19:01'! startUp: resuming "The image is either being newly started (resuming is true), or it's just been snapshotted. If this has just been a snapshot, skip all the startup stuff." | startupParameters launchers | self active ifTrue: [^self]. self active: true. resuming ifFalse: [^self]. HTTPClient determineIfRunningInBrowser. startupParameters _ AbstractLauncher extractParameters. (startupParameters includesKey: 'apiSupported' asUppercase ) ifTrue: [ HTTPClient browserSupportsAPI: ((startupParameters at: 'apiSupported' asUppercase) asUppercase = 'TRUE'). HTTPClient isRunningInBrowser ifFalse: [HTTPClient isRunningInBrowser: true]]. self checkForUpdates ifTrue: [^self]. self checkForPluginUpdate. launchers _ self installedLaunchers collect: [:launcher | launcher new]. launchers do: [:launcher | launcher parameters: startupParameters]. launchers do: [:launcher | Smalltalk at: #WorldState ifPresent: [ :ws | ws addDeferredUIMessage: [launcher startUp] fixTemps]]! ! !AutoStart class methodsFor: 'accessing'! addLauncherFirst: launcher self installedLaunchers addFirst: launcher! ! !AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:34'! active ^ Active == true! ! !AutoStart class methodsFor: 'private' stamp: 'mir 9/7/2004 13:36'! active: aBoolean Active := aBoolean! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 3/5/2004 20:43'! checkForPluginUpdate | pluginVersion updateURL | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^false]. pluginVersion _ AbstractLauncher extractParameters at: (SmalltalkImage current platformName copyWithout: Character space) asUppercase ifAbsent: [^false]. updateURL _ AbstractLauncher extractParameters at: 'UPDATE_URL' ifAbsent: [^false]. ^SystemVersion check: pluginVersion andRequestPluginUpdate: updateURL! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 11/13/2003 19:09'! checkForUpdates | availableUpdate updateServer | World ifNotNil: [ World install. ActiveHand position: 100@100]. HTTPClient isRunningInBrowser ifFalse: [^self processUpdates]. availableUpdate _ (AbstractLauncher extractParameters at: 'UPDATE' ifAbsent: [''] ) asInteger. availableUpdate ifNil: [^false]. updateServer _ AbstractLauncher extractParameters at: 'UPDATESERVER' ifAbsent: [AbstractLauncher extractParameters at: 'UPDATE_SERVER' ifAbsent: ['Squeakland']]. Utilities setUpdateServer: updateServer. ^SystemVersion checkAndApplyUpdates: availableUpdate! ! !AutoStart class methodsFor: 'updating' stamp: 'mir 3/4/2005 10:52'! processUpdates "Process update files from a well-known update server. This method is called at system startup time, Only if the preference #updateFromServerAtStartup is true is the actual update processing undertaken automatically" (Preferences valueOfFlag: #updateFromServerAtStartup) ifTrue: [ | choice | choice _ (PopUpMenu labels: 'Yes, Update\No, Not now\Don''t ask again' withCRs) startUpWithCaption: 'Do you want to check for updates\or maintenance fixes on the server?' withCRs. choice = 1 ifTrue: [Utilities updateFromServer]. choice = 3 ifTrue: [ Preferences setPreference: #updateFromServerAtStartup toValue: false. self inform: 'Remember to save you image to make this setting permant.']. ]. ^false! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:29'! test01metaclassName self assert: Dictionary class name = 'Dictionary class'. self assert: OrderedCollection class name = 'OrderedCollection class'. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:28'! test02metaclassNumberOfInstances self assert: Dictionary class allInstances size = 1. self assert: OrderedCollection class allInstances size = 1.! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:36'! test03superclass | s | self assert: Dictionary superclass == Set. self assert: OrderedCollection superclass == SequenceableCollection. s _ OrderedCollection new. s add: SequenceableCollection. s add: Collection. s add: Object. s add: ProtoObject. self assert: OrderedCollection allSuperclasses = s. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 11:39'! test04metaclassSuperclass | s | self assert: Dictionary class superclass == Set class. self assert: OrderedCollection class superclass == SequenceableCollection class. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'! test05metaclassSuperclassHierarchy | s | self assert: SequenceableCollection class instanceCount = 1. self assert: Collection class instanceCount = 1. self assert: Object class instanceCount = 1. self assert: ProtoObject class instanceCount = 1. s _ OrderedCollection new. s add: SequenceableCollection class. s add: Collection class. s add: Object class. s add: ProtoObject class. s add: Class. s add: ClassDescription. s add: Behavior. s add: Object. s add: ProtoObject. self assert: OrderedCollection class allSuperclasses = s. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:53'! test06ClassDescriptionAllSubInstances | cdNo clsNo metaclsNo | cdNo _ ClassDescription allSubInstances size. clsNo _ Class allSubInstances size . metaclsNo _ Metaclass allSubInstances size. self assert: cdNo = (clsNo + metaclsNo). ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 13:02'! test07bmetaclassPointOfCircularity self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:16'! test07metaclass self assert: OrderedCollection class class == Metaclass. self assert: OrderedCollection class class = Metaclass. self assert: Dictionary class class == Metaclass. self assert: Dictionary class class = Metaclass. self assert: Object class class == Metaclass. self assert: Object class class = Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:25'! test08BCCMhierarchy self assert: Class superclass == ClassDescription. self assert: Metaclass superclass == ClassDescription. self assert: ClassDescription superclass == Behavior. self assert: Behavior superclass = Object. self assert: Class class class == Metaclass. self assert: Metaclass class class == Metaclass. self assert: ClassDescription class class == Metaclass. self assert: Behavior class class == Metaclass. ! ! !BCCMTest methodsFor: 'testing' stamp: 'HJH 2/24/2003 12:43'! test09ObjectAllSubclasses | n2 | n2 _ Object allSubclasses size. self assert: n2 = (Object allSubclasses select: [:cls | cls class class == Metaclass or: [cls class == Metaclass]]) size! ! !BCCMTest commentStamp: '' prior: 0! This class contains some tests regarding the classes Behavior ClassDescription Class Metaclass --- ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:45'! errorFileFormat self error: 'malformed bdf format'! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:46'! errorUnsupported self error: 'unsupported bdf'! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:43'! getLine ^self upTo: Character cr.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'! initialize properties _ Dictionary new.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/28/2002 05:08'! read | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width blt lastAscii pointSize ret stream | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth _ 0. minAscii _ 9999. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. 1 to: charsNum do: [:i | array _ self readOneCharacter. stream _ ReadStream on: array. form _ stream next. encoding _ stream next. bbx _ stream next. form ifNotNil: [ width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. chars add: array. ]. ]. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" charsNum > 256 ifTrue: [ "it should be 94x94 charset, and should be fixed width font" strikeWidth _ 94*94*maxWidth. maxAscii _ 94*94. minAscii _ 0. xTable _ XTableForFixedFont new. xTable maxAscii: 94*94. xTable width: maxWidth. ] ifFalse: [ xTable _ (Array new: 258) atAllPut: 0. ]. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. lastAscii _ 0. charsNum > 256 ifTrue: [ 1 to: charsNum do: [:i | stream _ ReadStream on: (chars at: i). form _ stream next. encoding _ stream next. bbx _ stream next. encoding _ ((encoding // 256) - 33) * 94 + ((encoding \\ 256) - 33). blt copy: ((encoding * maxWidth)@0 extent: maxWidth@height) from: 0@0 in: form. ]. ] ifFalse: [ 1 to: charsNum do: [:i | stream _ ReadStream on: (chars at: i). form _ stream next. encoding _ stream next. bbx _ stream next. lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]. blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). lastAscii _ encoding. ] ]. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" ! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'nop 1/18/2000 19:44'! readAttributes | str a | "I don't handle double-quotes correctly, but it works" self reset. [self atEnd] whileFalse: [ str _ self getLine. (str beginsWith: 'STARTCHAR') ifTrue: [self skip: (0 - str size - 1). ^self]. a _ str substrings. properties at: a first asSymbol put: a allButFirst. ]. self error: 'file seems corrupted'.! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 8/5/2003 11:31'! readChars | strikeWidth ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx array width pointSize stream | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. maxWidth _ 0. minAscii _ 9999. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. 1 to: charsNum do: [:i | array _ self readOneCharacter. stream _ ReadStream on: array. form _ stream next. encoding _ stream next. bbx _ stream next. form ifNotNil: [ width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. chars add: array. ]. ]. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. ^ chars. ! ! !BDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2004 23:21'! readOneCharacter | str a encoding bbx form bits hi low pos | ((str _ self getLine) beginsWith: 'ENDFONT') ifTrue: [^ {nil. nil. nil}]. (str beginsWith: 'STARTCHAR') ifFalse: [self errorFileFormat]. ((str _ self getLine) beginsWith: 'ENCODING') ifFalse: [self errorFileFormat]. encoding _ Integer readFromString: str substrings second. (self getLine beginsWith: 'SWIDTH') ifFalse: [self errorFileFormat]. (self getLine beginsWith: 'DWIDTH') ifFalse: [self errorFileFormat]. ((str _ self getLine) beginsWith: 'BBX') ifFalse: [self errorFileFormat]. a _ str substrings. bbx _ (2 to: 5) collect: [:i | Integer readFromString: (a at: i)]. ((str _ self getLine) beginsWith: 'ATTRIBUTES') ifTrue: [str _ self getLine]. (str beginsWith: 'BITMAP') ifFalse: [self errorFileFormat]. form _ Form extent: (bbx at: 1)@(bbx at: 2). bits _ form bits. pos _ 0. 1 to: (bbx at: 2) do: [:t | 1 to: (((bbx at: 1) - 1) // 8 + 1) do: [:i | hi _ (('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1) bitShift: 4. low _ ('0123456789ABCDEF' indexOf: (self next asUppercase)) - 1. bits byteAt: (pos+i) put: (hi+low). ]. self next ~= Character cr ifTrue: [self errorFileFormat]. pos _ pos + ((((bbx at: 1) // 32) + 1) * 4). ]. (self getLine beginsWith: 'ENDCHAR') ifFalse: [self errorFileFormat]. encoding < 0 ifTrue: [^{nil. nil. nil}]. ^{form. encoding. bbx}. ! ! !BDFFontReader commentStamp: '' prior: 0! I am a conversion utility for reading X11 Bitmap Distribution Format fonts. My code is derived from the multilingual Squeak changeset written by OHSHIMA Yoshiki (ohshima@is.titech.ac.jp), although all support for fonts with more than 256 glyphs has been ripped out. See http://www.is.titech.ac.jp/~ohshima/squeak/squeak-multilingual-e.html . My class methods contain tools for fetching BDF source files from a well-known archive site, batch conversion to Squeak's .sf2 format, and installation of these fonts as TextStyles. Also, the legal notices for the standard 75dpi fonts I process this way are included as "x11FontLegalNotices'.! !BDFFontReader class methodsFor: 'file creation' stamp: 'nop 1/23/2000 19:00'! convertFilesNamed: fileName toFamilyNamed: familyName inDirectoryNamed: dirName "BDFFontReader convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: '' " "This utility converts X11 BDF font files to Squeak .sf2 StrikeFont files." "For this utility to work as is, the BDF files must be named 'familyNN.bdf', and must reside in the directory named by dirName (use '' for the current directory). The output StrikeFont files will be named familyNN.sf2, and will be placed in the current directory." | f allFontNames sizeChars dir | "Check for matching file names." dir _ dirName isEmpty ifTrue: [FileDirectory default] ifFalse: [FileDirectory default directoryNamed: dirName]. allFontNames _ dir fileNamesMatching: fileName , '##.bdf'. allFontNames isEmpty ifTrue: [^ self error: 'No files found like ' , fileName , 'NN.bdf']. Utilities informUserDuring: [:info | allFontNames do: [:fname | info value: 'Converting ', familyName, ' BDF file ', fname, ' to SF2 format'. sizeChars _ (fname copyFrom: fileName size + 1 to: fname size) copyUpTo: $. . f _ StrikeFont new readBDFFromFile: (dir fullNameFor: fname) name: familyName, sizeChars. f writeAsStrike2named: familyName, sizeChars, '.sf2'. ]. ]! ! !BDFFontReader class methodsFor: 'file creation' stamp: 'yo 5/25/2004 10:52'! new ^ self basicNew. ! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:43'! convertX11FontsToStrike2 "BDFFontReader convertX11FontsToStrike2" "Given a set of standard X11 BDF font files (probably downloaded via BDFFontReader downloadFonts), produce .sf2 format fonts. The source and destination directory is the current directory." "Charter currently tickles a bug in the BDF parser. Skip it for now." "self convertFilesNamed: 'charR' toFamilyNamed: 'Charter' inDirectoryNamed: ''." self convertFilesNamed: 'courR' toFamilyNamed: 'Courier' inDirectoryNamed: ''. self convertFilesNamed: 'helvR' toFamilyNamed: 'Helvetica' inDirectoryNamed: ''. self convertFilesNamed: 'lubR' toFamilyNamed: 'LucidaBright' inDirectoryNamed: ''. self convertFilesNamed: 'luRS' toFamilyNamed: 'Lucida' inDirectoryNamed: ''. self convertFilesNamed: 'lutRS' toFamilyNamed: 'LucidaTypewriter' inDirectoryNamed: ''. self convertFilesNamed: 'ncenR' toFamilyNamed: 'NewCenturySchoolbook' inDirectoryNamed: ''. self convertFilesNamed: 'timR' toFamilyNamed: 'TimesRoman' inDirectoryNamed: ''.! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 2/11/2001 00:24'! downloadFonts "BDFFontReader downloadFonts" "Download a standard set of BDF sources from x.org. The combined size of these source files is around 1.2M; after conversion to .sf2 format they may be deleted." | heads tails filenames baseUrl basePath newUrl newPath document f | heads _ #( 'charR' 'courR' 'helvR' 'lubR' 'luRS' 'lutRS' 'ncenR' 'timR' ). tails _ #( '08' '10' '12' '14' '18' '24'). filenames _ OrderedCollection new. heads do: [:head | filenames addAll: (tails collect: [:tail | head , tail , '.bdf']) ]. baseUrl _ Url absoluteFromText: 'http://ftp.x.org/pub/R6.4/xc/fonts/bdf/75dpi/'. basePath _ baseUrl path. filenames do: [:filename | newUrl _ baseUrl clone. newPath _ OrderedCollection newFrom: basePath. newPath addLast: filename. newUrl path: newPath. Utilities informUser: 'Fetching ' , filename during: [document _ newUrl retrieveContents]. f _ CrLfFileStream newFileNamed: filename. f nextPutAll: document content. f close. ]. ! ! !BDFFontReader class methodsFor: 'resource download' stamp: 'nop 1/23/2000 18:44'! installX11Fonts "BDFFontReader installX11Fonts" "Installs previously-converted .sf2 fonts into the TextConstants dictionary. This makes them available as TextStyles everywhere in the image." | families fontArray textStyle | families _ #( 'Courier' 'Helvetica' 'LucidaBright' 'Lucida' 'LucidaTypewriter' 'NewCenturySchoolbook' 'TimesRoman' ). families do: [:family | fontArray _ StrikeFont readStrikeFont2Family: family. textStyle _ TextStyle fontArray: fontArray. TextConstants at: family asSymbol put: textStyle. ]. ! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 2/11/2001 00:22'! gettingAndInstallingTheFonts "Download the 1.3M of BDF font source files from x.org: BDFFontReader downloadFonts. Convert them to .sf2 StrikeFont files: BDFFontReader convertX11FontsToStrike2. Install them into the system as TextStyles: BDFFontReader installX11Fonts. Read the legal notices in 'BDFFontReader x11FontLegalNotices' before redistributing images containing these fonts."! ! !BDFFontReader class methodsFor: 'documentation' stamp: 'nop 1/23/2000 18:30'! x11FontLegalNotices ^ 'The X11 BDF fonts contain copyright and license information as comments in the font source code. For the font family files "cour" (Courier), "helv" (Helvetica), "ncen" (New Century Schoolbook), and "tim" (Times Roman) the notice reads: COMMENT Copyright 1984-1989, 1994 Adobe Systems Incorporated. COMMENT Copyright 1988, 1994 Digital Equipment Corporation. COMMENT COMMENT Adobe is a trademark of Adobe Systems Incorporated which may be COMMENT registered in certain jurisdictions. COMMENT Permission to use these trademarks is hereby granted only in COMMENT association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, distribute and sell this software COMMENT and its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notices appear in all COMMENT copies and that both those copyright notices and this permission COMMENT notice appear in supporting documentation, and that the names of COMMENT Adobe Systems and Digital Equipment Corporation not be used in COMMENT advertising or publicity pertaining to distribution of the software COMMENT without specific, written prior permission. Adobe Systems and COMMENT Digital Equipment Corporation make no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. For the font family files "char" (Charter), the notice reads: COMMENT Copyright 1988 Bitstream, Inc., Cambridge, Massachusetts, USA COMMENT Bitstream and Charter are registered trademarks of Bitstream, Inc. COMMENT COMMENT The names "Bitstream" and "Charter" are registered trademarks of COMMENT Bitstream, Inc. Permission to use these trademarks is hereby COMMENT granted only in association with the images described in this file. COMMENT COMMENT Permission to use, copy, modify, and distribute this software and COMMENT its documentation for any purpose and without fee is hereby COMMENT granted, provided that the above copyright notice appear in all COMMENT copies and that both that copyright notice and this permission COMMENT notice appear in supporting documentation, and that the name of COMMENT Bitstream not be used in advertising or publicity pertaining to COMMENT distribution of the software without specific, written prior COMMENT permission. Bitstream makes no representations about the COMMENT suitability of this software for any purpose. It is provided "as COMMENT is" without express or implied warranty. COMMENT COMMENT BITSTREAM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, COMMENT INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN COMMENT NO EVENT SHALL BITSTREAM BE LIABLE FOR ANY SPECIAL, INDIRECT OR COMMENT CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS COMMENT OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, COMMENT NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN COMMENT CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. For the font family files "lu" (Lucida), "lub" (Lucida Bright), and "lut" (Lucida Typewriter), the notice reads: COMMENT (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered COMMENT trademark of Bigelow & Holmes. See LEGAL NOTICE file for terms COMMENT of the license. The LEGAL NOTICE contains: This is the LEGAL NOTICE pertaining to the Lucida fonts from Bigelow & Holmes: NOTICE TO USER: The source code, including the glyphs or icons forming a par of the OPEN LOOK TM Graphic User Interface, on this tape and in these files is copyrighted under U.S. and international laws. Sun Microsystems, Inc. of Mountain View, California owns the copyright and has design patents pending on many of the icons. AT&T is the owner of the OPEN LOOK trademark associated with the materials on this tape. Users and possessors of this source code are hereby granted a nonexclusive, royalty-free copyright and design patent license to use this code in individual and commercial software. A royalty-free, nonexclusive trademark license to refer to the code and output as "OPEN LOOK" compatible is available from AT&T if, and only if, the appearance of the icons or glyphs is not changed in any manner except as absolutely necessary to accommodate the standard resolution of the screen or other output device, the code and output is not changed except as authorized herein, and the code and output is validated by AT&T. Bigelow & Holmes is the owner of the Lucida (R) trademark for the fonts and bit-mapped images associated with the materials on this tape. Users are granted a royalty-free, nonexclusive license to use the trademark only to identify the fonts and bit-mapped images if, and only if, the fonts and bit-mapped images are not modified in any way by the user. Any use of this source code must include, in the user documentation and internal comments to the code, notices to the end user as follows: (c) Copyright 1989 Sun Microsystems, Inc. Sun design patents pending in the U.S. and foreign countries. OPEN LOOK is a trademark of AT&T. Used by written permission of the owners. (c) Copyright Bigelow & Holmes 1986, 1985. Lucida is a registered trademark of Bigelow & Holmes. Permission to use the Lucida trademark is hereby granted only in association with the images and fonts described in this file. SUN MICROSYSTEMS, INC., AT&T, AND BIGELOW & HOLMES MAKE NO REPRESENTATIONS ABOUT THE SUITABILITY OF THIS SOURCE CODE FOR ANY PURPOSE. IT IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY OF ANY KIND. SUN MICROSYSTEMS, INC., AT&T AND BIGELOW & HOLMES, SEVERALLY AND INDIVIDUALLY, DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOURCE CODE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL SUN MICROSYSTEMS, INC., AT&T OR BIGELOW & HOLMES BE LIABLE FOR ANY SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOURCE CODE. '. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:36'! nextImage | colors | stream binary. self readHeader. biBitCount = 24 ifTrue:[^self read24BmpFile]. "read the color map" colors := self readColorMap. ^self readIndexedBmpFile: colors! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 17:24'! read24BmpFile "Read 24-bit pixel data from the given a BMP stream." | form formBits pixelLine bitsIndex | form _ Form extent: biWidth@biHeight depth: 32. pixelLine := ByteArray new: (((24 * biWidth) + 31) // 32) * 4. bitsIndex := form height - 1 * biWidth + 1. formBits := form bits. 1 to: biHeight do: [:i | pixelLine := stream nextInto: pixelLine. self read24BmpLine: pixelLine into: formBits startingAt: bitsIndex width: biWidth. bitsIndex := bitsIndex - biWidth. ]. ^ form ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:47'! read24BmpLine: pixelLine into: formBits startingAt: formBitsIndex width: width | pixIndex rgb bitsIndex | pixIndex _ 0. "pre-increment" bitsIndex := formBitsIndex-1. "pre-increment" 1 to: width do: [:j | rgb := (pixelLine at: (pixIndex := pixIndex+1)) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 8) + ((pixelLine at: (pixIndex := pixIndex+1)) bitShift: 16). rgb = 0 ifTrue:[rgb := 16rFF000001] ifFalse:[rgb := rgb + 16rFF000000]. formBits at: (bitsIndex := bitsIndex+1) put: rgb. ]. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 18:17'! readColorMap "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | colorCount colors maxLevel b g r ccStream | colorCount _ (bfOffBits - 54) // 4. "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" biBitCount = 16 ifTrue:[^nil]. colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" biBitCount = 1 ifTrue: [^ Array with: Color white with: Color black]. "default gray-scale color map" maxLevel _ (2 raisedTo: biBitCount) - 1. ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. ccStream := ReadStream on: (stream next: colorCount*4). colors _ Array new: colorCount. 1 to: colorCount do: [:i | b _ ccStream next. g _ ccStream next. r _ ccStream next. ccStream next. "skip reserved" colors at: i put: (Color r: r g: g b: b range: 255)]. ^ colors ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:20'! readHeader | reserved | bfType _ stream nextLittleEndianNumber: 2. bfSize _ stream nextLittleEndianNumber: 4. reserved _ stream nextLittleEndianNumber: 4. bfOffBits _ stream nextLittleEndianNumber: 4. biSize _ stream nextLittleEndianNumber: 4. biWidth _ stream nextLittleEndianNumber: 4. biHeight _ stream nextLittleEndianNumber: 4. biPlanes _ stream nextLittleEndianNumber: 2. biBitCount _ stream nextLittleEndianNumber: 2. biCompression _ stream nextLittleEndianNumber: 4. biSizeImage _ stream nextLittleEndianNumber: 4. biXPelsPerMeter _ stream nextLittleEndianNumber: 4. biYPelsPerMeter _ stream nextLittleEndianNumber: 4. biClrUsed _ stream nextLittleEndianNumber: 4. biClrImportant _ stream nextLittleEndianNumber: 4. ! ! !BMPReadWriter methodsFor: 'reading' stamp: 'ar 6/16/2002 15:35'! readIndexedBmpFile: colors "Read uncompressed pixel data of depth d from the given BMP stream, where d is 1, 4, 8, or 16" | form bytesPerRow pixelData pixelLine startIndex cm word formBits | colors ifNil:[form _ Form extent: biWidth@biHeight depth: biBitCount] ifNotNil:[form _ ColorForm extent: biWidth@biHeight depth: biBitCount. form colors: colors]. bytesPerRow _ (((biBitCount* biWidth) + 31) // 32) * 4. pixelData _ ByteArray new: bytesPerRow * biHeight. biHeight to: 1 by: -1 do: [:y | pixelLine _ stream next: bytesPerRow. startIndex _ ((y - 1) * bytesPerRow) + 1. pixelData replaceFrom: startIndex to: startIndex + bytesPerRow - 1 with: pixelLine startingAt: 1]. form bits copyFromByteArray: pixelData. biBitCount = 16 ifTrue:[ "swap red and blue components" cm _ Bitmap new: (1 << 15). word _ 0. 0 to: 31 do:[:r| 0 to: 31 do:[:g| 0 to: 31 do:[:b| cm at: (word _ word + 1) put: (b bitShift: 10) + (g bitShift: 5) + r]]]. cm at: 1 put: 1. formBits _ form bits. 1 to: formBits size do:[:i| word _ formBits at: i. word _ (cm at: (word bitAnd: 16r7FFF) + 1) + ((cm at: ((word bitShift: -16) bitAnd: 16r7FFF) +1) bitShift: 16). formBits at: i put: word. ]. ]. ^ form ! ! !BMPReadWriter methodsFor: 'writing' stamp: 'yo 2/18/2004 17:57'! nextPutImage: aForm | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen | depth := aForm depth. [#(1 4 8 32) includes: depth] whileFalse:[depth := depth + 1 asLargerPowerOfTwo]. image := aForm asFormOfDepth: depth. image unhibernate. bhSize _ 14. "# bytes in file header" biSize _ 40. "info header size in bytes" biWidth := image width. biHeight := image height. biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits _ biSize + bhSize + (4*biClrUsed). rowBytes _ ((depth min: 24) * biWidth + 31 // 32) * 4. biSizeImage _ biHeight * rowBytes. "Write the file header" stream position: 0. stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" stream nextLittleEndianNumber: 4 put: 0. "bfReserved" stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" stream position: bhSize. stream nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" stream nextLittleEndianNumber: 4 put: image width. "biWidth" stream nextLittleEndianNumber: 4 put: image height. "biHeight" stream nextLittleEndianNumber: 2 put: 1. "biPlanes" stream nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" stream nextLittleEndianNumber: 4 put: 0. "biCompression" stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" stream nextLittleEndianNumber: 4 put: biClrUsed. stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues _ image colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb _ colorValues at: i. 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j bitAnd: 16rFF)]]]. depth < 32 ifTrue: [ "depth = 1, 4 or 8." data _ image bits asByteArray. ppw _ 32 // depth. scanLineLen _ biWidth + ppw - 1 // ppw * 4. "# of bytes in line" 1 to: biHeight do: [:i | stream next: scanLineLen putAll: data startingAt: (biHeight-i)*scanLineLen+1. ]. ] ifFalse: [ 1 to: biHeight do:[:i | data _ (image copy: (0@(biHeight-i) extent: biWidth@1)) bits. 1 to: data size do: [:j | stream nextLittleEndianNumber: 3 put: (data at: j)]. 1 to: (data size*3)+3//4*4-(data size*3) do: [:j | stream nextPut: 0 "pad to 32-bits"] ]. ]. stream position = (bfOffBits + biSizeImage) ifFalse: [self error:'Write failure']. stream close.! ! !BMPReadWriter methodsFor: 'testing' stamp: 'ar 6/16/2002 15:27'! understandsImageFormat stream size < 54 ifTrue:[^false]. "min size = BITMAPFILEHEADER+BITMAPINFOHEADER" self readHeader. bfType = 19778 "BM" ifFalse:[^false]. biSize = 40 ifFalse:[^false]. biPlanes = 1 ifFalse:[^false]. bfSize <= stream size ifFalse:[^false]. biCompression = 0 ifFalse:[^false]. ^true! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:55'! displayAllFrom: fd "BMPReadWriter displayAllFrom: FileDirectory default" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [(Form fromBinaryStream: (fd readOnlyFileNamed: fName)) display. Display forceDisplayUpdate] on: Error do:[:nix|]. ]. ]. fd directoryNames do:[:fdName| self displayAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'testing' stamp: 'ar 6/16/2002 18:56'! readAllFrom: fd "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory default]" fd fileNames do:[:fName| (fName endsWith: '.bmp') ifTrue:[ [Form fromBinaryStream: (fd readOnlyFileNamed: fName)] on: Error do:[:nix]. ]. ]. fd directoryNames do:[:fdName| self readAllFrom: (fd directoryNamed: fdName) ].! ! !BMPReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('bmp')! ! !BOBTransformationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 6/4/2001 16:19'! drawSubmorphsOnREAL: aCanvas | newClip | (self innerBounds intersects: aCanvas clipRect) ifFalse: [^self]. newClip _ ((self innerBounds intersect: aCanvas clipRect) expandBy: 1) truncated. useRegularWarpBlt == true ifTrue: [ transform scale asFloat = 1.0 ifFalse: [ newClip _ self innerBounds. "avoids gribblies" ]. ^aCanvas transformBy: transform clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ]. aCanvas transform2By: transform "#transformBy: for pure WarpBlt" clippingTo: newClip during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing ! ! !BOBTransformationMorph methodsFor: 'drawing' stamp: 'RAA 6/4/2001 16:21'! drawSubmorphsOn: aCanvas | t | t _ [ self drawSubmorphsOnREAL: aCanvas ] timeToRun. "Q1 at: 3 put: t." ! ! !BOBTransformationMorph methodsFor: 'layout' stamp: 'dgd 2/21/2003 23:02'! layoutChanged "use the version from Morph" | myGuy | fullBounds := nil. owner ifNotNil: [owner layoutChanged]. submorphs notEmpty ifTrue: [(myGuy := self firstSubmorph) isWorldMorph ifFalse: [worldBoundsToShow = myGuy bounds ifFalse: [self changeWorldBoundsToShow: (worldBoundsToShow := myGuy bounds)]] "submorphs do: [:m | m ownerChanged]" "<< I don't see any reason for this"]! ! !BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 12:23'! delta ^delta! ! !BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 12:24'! delta: aPoint delta _ aPoint.! ! !BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'! offset ^offset! ! !BackgroundMorph methodsFor: 'accessing' stamp: 'fc 7/24/2004 13:50'! offset: aPoint offset _ aPoint! ! !BackgroundMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:20'! subBounds "calculate the submorph bounds" | subBounds | subBounds := nil. self submorphsDo: [:m | subBounds := subBounds isNil ifTrue: [m fullBounds] ifFalse: [subBounds merge: m fullBounds]]. ^subBounds! ! !BackgroundMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:16'! fullDrawOn: aCanvas (aCanvas isVisible: self fullBounds) ifFalse:[^self]. running ifFalse: [ ^aCanvas clipBy: (bounds translateBy: aCanvas origin) during:[:clippedCanvas| super fullDrawOn: clippedCanvas]]. (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self]. ! ! !BackgroundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:43'! initialize "initialize the state of the receiver" super initialize. "" offset _ 0 @ 0. delta _ 1 @ 0. running _ true! ! !BackgroundMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. running ifTrue: [aCustomMenu add: 'stop' translated action: #stopRunning] ifFalse: [aCustomMenu add: 'start' translated action: #startRunning]! ! !BackgroundMorph methodsFor: 'stepping and presenter' stamp: 'fc 7/24/2004 13:47'! step running ifTrue: [self slideBy: delta]! ! !BackgroundMorph class methodsFor: 'as yet unclassified' stamp: 'kfr 8/7/2004 16:10'! test "BackgroundMorph test" ^(BackgroundMorph new addMorph: (ImageMorph new image: Form fromUser))openInWorld.! ! !BadEqualer methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! = other self class = other class ifFalse: [^ false]. ^ 100 atRandom < 30 ! ! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always report #= correctly. Used for testing the EqualityTester.! !BadHasher methodsFor: 'comparing' stamp: 'mjr 8/20/2003 18:56'! hash "answer with a different hash some of the time" 100 atRandom < 30 ifTrue: [^ 1]. ^ 2! ! !BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! I am an object that doesn't always hash correctly. I am used for testing the HashTester.! !Bag methodsFor: 'comparing' stamp: 'md 10/17/2004 16:09'! = aBag "Two bags are equal if (a) they are the same 'kind' of thing. (b) they have the same size. (c) each element occurs the same number of times in both of them" (aBag isKindOf: Bag) ifFalse: [^false]. self size = aBag size ifFalse: [^false]. contents associationsDo: [:assoc| (aBag occurrencesOf: assoc key) = assoc value ifFalse: [^false]]. ^true ! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !BalloonBezierSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonBuffer commentStamp: '' prior: 0! BalloonBuffer is a repository for primitive data used by the BalloonEngine.! !BalloonCanvas methodsFor: 'accessing' stamp: 'ar 2/13/2001 21:07'! ensuredEngine engine ifNil:[ engine _ BalloonEngine new. "engine _ BalloonDebugEngine new" engine aaLevel: aaLevel. engine bitBlt: port. engine destOffset: origin. engine clipRect: clipRect. engine deferred: deferred. engine]. engine colorTransform: colorTransform. engine edgeTransform: transform. ^engine! ! !BalloonCanvas methodsFor: 'drawing' stamp: 'nk 5/1/2004 12:25'! frameRectangle: r width: w color: c "Draw a frame around the given rectangle" ^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c! ! !BalloonCanvas methodsFor: 'TODO' stamp: 'ar 12/31/2001 02:27'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c (self ifNoTransformWithIn: boundsRect) ifTrue:[^super drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !BalloonCanvas methodsFor: 'private' stamp: 'nk 5/1/2004 12:54'! image: aForm at: aPoint sourceRect: sourceRect rule: rule | warp dstRect srcQuad dstOffset center | (self ifNoTransformWithIn: sourceRect) & false ifTrue:[^super image: aForm at: aPoint sourceRect: sourceRect rule: rule]. dstRect _ (transform localBoundsToGlobal: (aForm boundingBox translateBy: aPoint)). dstOffset _ 0@0. "dstRect origin." "dstRect _ 0@0 corner: dstRect extent." center _ 0@0."transform globalPointToLocal: dstRect origin." srcQuad _ transform globalPointsToLocal: (dstRect innerCorners). srcQuad _ srcQuad collect:[:pt| pt - aPoint]. warp _ (WarpBlt current toForm: form) sourceForm: aForm; cellSize: 2; "installs a new colormap if cellSize > 1" combinationRule: Form over. warp copyQuad: srcQuad toRect: (dstRect translateBy: dstOffset). self frameRectangle: (aForm boundingBox translateBy: aPoint) color: Color green. "... TODO ... create a bitmap fill style from the form and use it for a simple rectangle."! ! !BalloonCanvas methodsFor: 'drawing-polygons' stamp: 'ar 8/26/2001 22:14'! drawPolygon: vertices fillStyle: aFillStyle "Fill the given polygon." self drawPolygon: vertices fillStyle: aFillStyle borderWidth: 0 borderColor: nil! ! !BalloonCanvas commentStamp: '' prior: 0! BalloonCanvas is a canvas using the BalloonEngine for drawing wherever possible. It has various methods which other canvases do not support due to the extra features of the balloon engine.! !BalloonEngine methodsFor: 'initialize' stamp: 'nk 9/26/2003 10:52'! initialize | w | w _ Display width > 2048 ifTrue: [ 4096 ] ifFalse: [ 2048 ]. externals _ OrderedCollection new: 100. span _ Bitmap new: w. bitBlt _ nil. self bitBlt: ((BitBlt toForm: Display) destRect: Display boundingBox; yourself). forms _ #(). deferred _ false.! ! !BalloonEngine methodsFor: 'copying' stamp: 'ar 3/6/2001 12:06'! copyBits (bitBlt notNil and:[bitBlt destForm notNil]) ifTrue:[bitBlt destForm unhibernate]. self copyLoopFaster.! ! !BalloonEngine commentStamp: '' prior: 0! BalloonEngine is the representative for the Balloon engine inside Squeak. For most purposes it should not be used directly but via BalloonCanvas since this ensures proper initialization and is polymorphic with other canvas uses.! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:55'! initEdgeConstants "Initialize the edge constants" "Edge primitive types" GEPrimitiveEdge := 2. "External edge - not handled by the GE" GEPrimitiveWideEdge := 3. "Wide external edge" GEPrimitiveLine := 4. "Straight line" GEPrimitiveWideLine := 5. "Wide line" GEPrimitiveBezier := 6. "Quadratic bezier curve" GEPrimitiveWideBezier := 7. "Wide bezier curve" "Special flags" GEPrimitiveWide := 16r01. "Flag determining a wide primitive" GEPrimitiveWideMask := 16rFE. "Mask for clearing the wide flag" GEEdgeFillsInvalid := 16r10000. "Flag determining if left/right fills of an edge are invalid" GEEdgeClipFlag := 16r20000. "Flag determining if this is a clip edge" "General edge state constants" GEXValue := 4. "Current raster x" GEYValue := 5. "Current raster y" GEZValue := 6. "Current raster z" GENumLines := 7. "Number of scan lines remaining" GEFillIndexLeft := 8. "Left fill index" GEFillIndexRight := 9. "Right fill index" GEBaseEdgeSize := 10. "Basic size of each edge" "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "General Line state constants" GLXDirection := 10. "Direction of edge (1: left-to-right; -1: right-to-left)" GLYDirection := 11. "Direction of edge (1: top-to-bottom; -1: bottom-to-top)" GLXIncrement := 12. "Increment at each scan line" GLError := 13. "Current error" GLErrorAdjUp := 14. "Error to add at each scan line" GLErrorAdjDown := 15. "Error to subtract on roll-over" "Note: The following entries are only needed before the incremental state is computed. They are therefore aliased to the error values above" GLEndX := 14. "End X of line" GLEndY := 15. "End Y of line" GLBaseSize := 16. "Basic size of each line" "Additional stuff for wide lines" GLWideFill := 16. "Current fill of line" GLWideWidth := 17. "Current width of line" GLWideEntry := 18. "Initial steps" GLWideExit := 19. "Final steps" GLWideExtent := 20. "Target width" GLWideSize := 21. "Size of wide lines" "General Bezier state constants" GBUpdateData := 10. "Incremental update data for beziers" GBUpdateX := 0. "Last computed X value (24.8)" GBUpdateY := 1. "Last computed Y value (24.8)" GBUpdateDX := 2. "Delta X forward difference step (8.24)" GBUpdateDY := 3. "Delta Y forward difference step (8.24)" GBUpdateDDX := 4. "Delta DX forward difference step (8.24)" GBUpdateDDY := 5. "Delta DY forward difference step (8.24)" "Note: The following four entries are only needed before the incremental state is computed. They are therefore aliased to the incremental values above" GBViaX := 12. "via x" GBViaY := 13. "via y" GBEndX := 14. "end x" GBEndY := 15. "end y" GBBaseSize := 16. "Basic size of each bezier. Note: MUST be greater or equal to the size of lines" "Additional stuff for wide beziers" GBWideFill := 16. "Current fill of line" GBWideWidth := 17. "Current width of line" GBWideEntry := 18. "Initial steps" GBWideExit := 19. "Final steps" GBWideExtent := 20. "Target extent" GBFinalX := 21. "Final X value" GBWideUpdateData := 22. "Update data for second curve" GBWideSize := 28. "Size of wide beziers" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initFillConstants "Initialize the fill constants" "Fill primitive types" GEPrimitiveFill := 16r100. GEPrimitiveLinearGradientFill := 16r200. GEPrimitiveRadialGradientFill := 16r300. GEPrimitiveClippedBitmapFill := 16r400. GEPrimitiveRepeatedBitmapFill := 16r500. "General fill state constants" GEBaseFillSize := 4. "Basic size of each fill" "Oriented fill constants" GFOriginX := 4. "X origin of fill" GFOriginY := 5. "Y origin of fill" GFDirectionX := 6. "X direction of fill" GFDirectionY := 7. "Y direction of fill" GFNormalX := 8. "X normal of fill" GFNormalY := 9. "Y normal of fill" "Gradient fill constants" GFRampLength := 10. "Length of following color ramp" GFRampOffset := 12. "Offset of first ramp entry" GGBaseSize := 12. "Bitmap fill constants" GBBitmapWidth := 10. "Width of bitmap" GBBitmapHeight := 11. "Height of bitmap" GBBitmapDepth := 12. "Depth of bitmap" GBBitmapSize := 13. "Size of bitmap words" GBBitmapRaster := 14. "Size of raster line" GBColormapSize := 15. "Size of colormap, if any" GBTileFlag := 16. "True if the bitmap is tiled" GBColormapOffset := 18. "Offset of colormap, if any" GBMBaseSize := 18. "Basic size of bitmap fill" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 19:59'! initPrimitiveConstants "Initialize the primitive constants" "Primitive type constants" GEPrimitiveUnknown := 0. GEPrimitiveEdgeMask := 16rFF. GEPrimitiveFillMask := 16rFF00. GEPrimitiveTypeMask := 16rFFFF. "General state constants (Note: could be compressed later)" GEObjectType := 0. "Type of object" GEObjectLength := 1. "Length of object" GEObjectIndex := 2. "Index into external objects" GEObjectUnused := 3. "Currently unused" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:00'! initStateConstants "Initialize the state Constants" GEStateUnlocked := 0. "Buffer is unlocked and can be modified as wanted" GEStateAddingFromGET := 1. "Adding edges from the GET" GEStateWaitingForEdge := 2. "Waiting for edges added to GET" GEStateScanningAET := 3. "Scanning the active edge table" GEStateWaitingForFill := 4. "Waiting for a fill to mix in during AET scan" GEStateBlitBuffer := 5. "Blt the current scan line" GEStateUpdateEdges := 6. "Update edges to next scan line" GEStateWaitingChange := 7. "Waiting for a changed edge" GEStateCompleted := 8. "Rendering completed" "Error constants" GErrorNoMoreSpace := 1. "No more space in collection" GErrorBadState := 2. "Tried to call a primitive while engine in bad state" GErrorNeedFlush := 3. "Tried to call a primitive that requires flushing before" "Incremental error constants" GErrorGETEntry := 4. "Unknown entry in GET" GErrorFillEntry := 5. "Unknown FILL encountered" GErrorAETEntry := 6. "Unknown entry in AET" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:04'! initWorkBufferConstants "Initialize the work buffer constants" "General work buffer constants" GWMagicNumber := 16r416E6469. "Magic number" GWHeaderSize := 128. "Size of header" GWMinimalSize := 256. "Minimal size of work buffer" "Header entries" GWMagicIndex := 0. "Index of magic number" GWSize := 1. "Size of full buffer" GWState := 2. "Current state (e.g., locked or not." "Buffer entries" GWObjStart := 8. "objStart" GWObjUsed := 9. "objUsed" GWBufferTop := 10. "wbTop" GWGETStart := 11. "getStart" GWGETUsed := 12. "getUsed" GWAETStart := 13. "aetStart" GWAETUsed := 14. "aetUsed" "Transform entries" GWHasEdgeTransform := 16. "True if we have an edge transformation" GWHasColorTransform := 17. "True if we have a color transformation" GWEdgeTransform := 18. "2x3 edge transformation" GWColorTransform := 24. "8 word RGBA color transformation" "Span entries" GWSpanStart := 32. "spStart" GWSpanSize := 33. "spSize" GWSpanEnd := 34. "spEnd" GWSpanEndAA := 35. "spEndAA" "Bounds entries" GWFillMinX := 36. "fillMinX" GWFillMaxX := 37. "fillMaxX" GWFillMinY := 38. "fillMinY" GWFillMaxY := 39. "fillMaxY" GWFillOffsetX := 40. "fillOffsetX" GWFillOffsetY := 41. "fillOffsetY" GWClipMinX := 42. GWClipMaxX := 43. GWClipMinY := 44. GWClipMaxY := 45. GWDestOffsetX := 46. GWDestOffsetY := 47. "AA entries" GWAALevel := 48. "aaLevel" GWAAShift := 49. "aaShift" GWAAColorShift := 50. "aaColorShift" GWAAColorMask := 51. "aaColorMask" GWAAScanMask := 52. "aaScanMask" GWAAHalfPixel := 53. "aaHalfPixel" "Misc entries" GWNeedsFlush := 63. "True if the engine may need a flush" GWStopReason := 64. "stopReason" GWLastExportedEdge := 65. "last exported edge" GWLastExportedFill := 66. "last exported fill" GWLastExportedLeftX := 67. "last exported leftX" GWLastExportedRightX := 68. "last exported rightX" GWClearSpanBuffer := 69. "Do we have to clear the span buffer?" GWPointListFirst := 70. "First point list in buffer" GWPoint1 := 80. GWPoint2 := 82. GWPoint3 := 84. GWPoint4 := 86. GWCurrentY := 88. "Profile stats" GWTimeInitializing := 90. GWCountInitializing := 91. GWTimeFinishTest := 92. GWCountFinishTest := 93. GWTimeNextGETEntry := 94. GWCountNextGETEntry := 95. GWTimeAddAETEntry := 96. GWCountAddAETEntry := 97. GWTimeNextFillEntry := 98. GWCountNextFillEntry := 99. GWTimeMergeFill := 100. GWCountMergeFill := 101. GWTimeDisplaySpan := 102. GWCountDisplaySpan := 103. GWTimeNextAETEntry := 104. GWCountNextAETEntry := 105. GWTimeChangeAETEntry := 106. GWCountChangeAETEntry := 107. "Bezier stats" GWBezierMonotonSubdivisions := 108. "# of subdivision due to non-monoton beziers" GWBezierHeightSubdivisions := 109. "# of subdivisions due to excessive height" GWBezierOverflowSubdivisions := 110. "# of subdivisions due to possible int overflow" GWBezierLineConversions := 111. "# of beziers converted to lines" GWHasClipShapes := 112. "True if the engine contains clip shapes" GWCurrentZ := 113. "Current z value of primitives" ! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:08'! initialize "BalloonEngineConstants initialize" self initStateConstants. self initWorkBufferConstants. self initPrimitiveConstants. self initEdgeConstants. self initFillConstants. self initializeInstVarNames: BalloonEngine prefixedBy: 'BE'. self initializeInstVarNames: BalloonEdgeData prefixedBy: 'ET'. self initializeInstVarNames: BalloonFillData prefixedBy: 'FT'.! ! !BalloonEngineConstants class methodsFor: 'pool definition' stamp: 'ar 5/18/2003 20:07'! initializeInstVarNames: aClass prefixedBy: aString | token value | aClass instVarNames doWithIndex:[:instVarName :index| token _ (aString, instVarName first asUppercase asString, (instVarName copyFrom: 2 to: instVarName size),'Index') asSymbol. value _ index - 1. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: value. ]. token _ (aString, aClass name,'Size') asSymbol. (self bindingOf: token) ifNil:[self addClassVarName: token]. (self bindingOf: token) value: aClass instSize.! ! !BalloonFillData commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:44'! testDefaultFont "(self selector: #testDefaultFont) debug" self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont.! ! !BalloonFontTest methodsFor: 'testing' stamp: 'sd 12/9/2001 21:55'! testSpecificFont "(self selector: #testSpecificFont) debug" | aMorph | aMorph := RectangleMorph new. self assert: RectangleMorph new balloonFont = BalloonMorph balloonFont. self assert: RectangleMorph new defaultBalloonFont = BalloonMorph balloonFont. aMorph balloonFont: (StrikeFont familyName: #ComicPlain size: 19). self assert: aMorph balloonFont = (StrikeFont familyName: #ComicPlain size: 19). "The next test is horrible because I do no know how to access the font with the appropiate interface" self assert: (((BalloonMorph getTextMorph: 'lulu' for: aMorph) text runs at: 1) at: 1) font = (StrikeFont familyName: #ComicPlain size: 19)! ! !BalloonLineSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ self class balloonColor! ! !BalloonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:20'! initialize "initialize the state of the receiver" super initialize. "" self beSmoothCurve. offsetFromTarget _ 0 @ 0! ! !BalloonMorph methodsFor: 'initialization' stamp: 'RAA 7/1/2001 18:48'! popUpForHand: aHand "Pop up the receiver as balloon help for the given hand" | worldBounds | self lock. self fullBounds. "force layout" self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber. aHand world addMorphFront: self. "So that if the translation below makes it overlap the receiver, it won't interfere with the rootMorphsAt: logic and hence cause flashing. Without this, flashing happens, believe me!!" ((worldBounds _ aHand world bounds) containsRect: self bounds) ifFalse: [self bounds: (self bounds translatedToBeWithin: worldBounds)]. aHand balloonHelp: self. ! ! !BalloonMorph methodsFor: 'menus' stamp: 'wiz 12/30/2004 17:14'! adjustedCenter "Return the center of the original textMorph box within the balloon." ^ (self vertices last: 4) average rounded ! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sd 12/5/2001 20:27'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | tm vertices | tm _ self getTextMorph: str for: morph. vertices _ self getVertices: tm bounds. vertices _ self getBestLocation: vertices for: morph corner: cornerName. ^ self new color: morph balloonColor; setVertices: vertices; addMorph: tm; setTarget: morph! ! !BalloonMorph class methodsFor: 'utility' stamp: 'nk 9/1/2004 10:47'! chooseBalloonFont "BalloonMorph chooseBalloonFont" Preferences chooseFontWithPrompt: 'Select the font to be used for balloon help' translated andSendTo: self withSelector: #setBalloonFontTo: highlight: BalloonFont! ! !BalloonMorph class methodsFor: 'private' stamp: 'sd 12/5/2001 20:28'! getTextMorph: aStringOrMorph for: balloonOwner "Construct text morph." | m text | aStringOrMorph isMorph ifTrue: [m _ aStringOrMorph] ifFalse: [BalloonFont ifNil: [text _ aStringOrMorph] ifNotNil: [text _ Text string: aStringOrMorph attribute: (TextFontReference toFont: balloonOwner balloonFont)]. m _ (TextMorph new contents: text) centered]. m setToAdhereToEdge: #adjustedCenter. ^ m! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ GradientFillStyle ramp: {0.0 -> Color black. 1.0 -> Color white}! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 10! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" | result | result _ GradientFillStyle ramp: {0.0 -> Color green. 0.5 -> Color yellow. 1.0 -> Color red}. result radial: true. ^ result! ! !BalloonRectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:41'! initialize "initialize the state of the receiver" super initialize. "" self extent: 100 @ 100! ! !BalloonRectangleMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! !BalloonRectangleMorph commentStamp: '' prior: 0! BalloonRectangleMorph is an example for drawing using the BalloonEngine.! !BalloonSolidFillSimulation commentStamp: '' prior: 0! This class is a simulation of the code that's run by the Balloon engine. For debugging purposes only.! !BalloonState commentStamp: '' prior: 0! This class is a repository for data which needs to be preserved during certain operations of BalloonCanvas.! !Base64MimeConverter methodsFor: 'conversion' stamp: 'ls 2/10/2001 13:26'! mimeEncode "Convert from data to 6 bit characters." | phase1 phase2 raw nib lineLength | phase1 _ phase2 _ false. lineLength := 0. [dataStream atEnd] whileFalse: [ lineLength >= 70 ifTrue: [ mimeStream cr. lineLength := 0. ]. data _ raw _ dataStream next asInteger. nib _ (data bitAnd: 16rFC) bitShift: -2. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase1 _ true]. data _ ((data bitAnd: 3) bitShift: 8) + raw asInteger. nib _ (data bitAnd: 16r3F0) bitShift: -4. mimeStream nextPut: (ToCharTable at: nib+1). (raw _ dataStream next) ifNil: [raw _ 0. phase2 _ true]. data _ ((data bitAnd: 16rF) bitShift: 8) + (raw asInteger). nib _ (data bitAnd: 16rFC0) bitShift: -6. mimeStream nextPut: (ToCharTable at: nib+1). nib _ (data bitAnd: 16r3F). mimeStream nextPut: (ToCharTable at: nib+1). lineLength := lineLength + 4.]. phase1 ifTrue: [mimeStream skip: -2; nextPut: $=; nextPut: $=. ^ mimeStream]. phase2 ifTrue: [mimeStream skip: -1; nextPut: $=. ^ mimeStream]. ! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:37'! setUp message _ ReadWriteStream on: (String new: 10). message nextPutAll: 'Hi There!!'.! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:34'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !Base64MimeConverterTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:45'! testMimeEncodeDecode | encoded | encoded _ Base64MimeConverter mimeEncode: message. self should: [encoded contents = 'SGkgVGhlcmUh']. self should: [(Base64MimeConverter mimeDecodeToChars: encoded) contents = message contents].! ! !Base64MimeConverterTest commentStamp: '' prior: 0! This is the unit test for the class Base64MimeConverter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/24/2004 23:13'! randomBitsFromSoundInput: bitCount "Answer a positive integer with the given number of random bits of 'noise' from a sound input source. Typically, one would use a microphone or line input as the sound source, although many sound cards have enough thermal noise that you get random low-order sample bits even with no microphone connected. Only the least signficant bit of the samples is used. Since not all sound cards support 16-bits of sample resolution, we use the lowest bit that changes." "(1 to: 10) collect: [:i | BaseSoundSystem new randomBitsFromSoundInput: 512]" | recorder buf mid samples bitMask randomBits bit | "collect some sound data" recorder _ SoundRecorder new clearRecordedSound. recorder resumeRecording. (Delay forSeconds: 1) wait. recorder stopRecording. buf _ recorder condensedSamples. "grab bitCount samples from the middle" mid _ buf monoSampleCount // 2. samples _ buf copyFrom: mid to: mid + bitCount - 1. "find the least significant bit that varies" bitMask _ 1. [bitMask < 16r10000 and: [(samples collect: [:s | s bitAnd: bitMask]) asSet size < 2]] whileTrue: [bitMask _ bitMask bitShift: 1]. bitMask = 16r10000 ifTrue: [^ self error: 'sound samples do not vary']. "pack the random bits into a positive integer" randomBits _ 0. 1 to: samples size do: [:i | bit _ ((samples at: i) bitAnd: bitMask) = 0 ifTrue: [0] ifFalse: [1]. randomBits _ (randomBits bitShift: 1) + bit]. ^ randomBits ! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 22:18'! sampledSoundChoices ^ SampledSound soundNames! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown SoundPlayer shutDown ! ! !BaseSoundSystem methodsFor: 'misc' stamp: 'ads 7/30/2003 23:17'! soundNamed: soundName ^ SampledSound soundNamed: soundName! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'! beep "There is sound support, so we use the default sampled sound for a beep." Preferences soundsEnabled ifTrue: [ SampledSound beep]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:20'! playSampledSound: samples rate: rate Preferences soundsEnabled ifTrue: [ (SampledSound samples: samples samplingRate: rate) play]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'! playSoundNamed: soundName "There is sound support, so we play the given sound." Preferences soundsEnabled ifTrue: [ SampledSound playSoundNamed: soundName asString]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:22'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName Preferences soundsEnabled ifTrue: [ (SampledSound soundNames includes: soundName) ifFalse: [ (FileDirectory default fileExists: aifFileName) ifTrue: [ SampledSound addLibrarySoundNamed: soundName fromAIFFfileNamed: aifFileName]]. (SampledSound soundNames includes: soundName) ifTrue: [ SampledSound playSoundNamed: soundName]]! ! !BaseSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:23'! playSoundNamedOrBeep: soundName "There is sound support, so we play the given sound instead of beeping." Preferences soundsEnabled ifTrue: [ ^self playSoundNamed: soundName]! ! !BaseSoundSystem commentStamp: 'gk 2/24/2004 08:35' prior: 0! This is the normal sound system in Squeak and is registered in SoundService - an AppRegistry - so that a small highlevel protocol for playing sounds can be used in a pluggable fashion. More information available in superclass.! !BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! initialize SoundService register: self new.! ! !BaseSoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! unload SoundService registeredClasses do: [:ss | (ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color yellow darker! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !BasicButton methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:52'! initialize "initialize the state of the receiver" super initialize. "" self label: 'Button'; useRoundedCorners! ! !BasicButton methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:56'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'change label...' translated action: #setLabel! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:02'! classComment classComment ifNil: [^ '']. ^ classComment text ifNil: ['']! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [classComment _ aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment _ nil] ifFalse: [ self error: 'use aClass classComment:'. classComment _ RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! classComment: aString stamp: aStamp "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment _ aString] ifFalse: [(aString == nil or: [aString size = 0]) ifTrue: [classComment _ nil] ifFalse: [self error: 'use aClass classComment:'. classComment _ RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentRemoteStr ^ classComment! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp "Answer the comment stamp for the class" ^ commentStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp: aStamp commentStamp _ aStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! dateCommentLastSubmitted "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time guys, return nil" "RecentMessageSet organization dateCommentLastSubmitted" | aStamp tokens | (aStamp _ self commentStamp) isEmptyOrNil ifTrue: [^ nil]. tokens _ aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! hasNoComment "Answer whether the class classified by the receiver has a comment." ^classComment == nil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! hasSubject ^ self subject notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! subject ^ subject.! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:03'! fileOutCommentOn: aFileStream moveSource: moveSource toFile: fileIndex "Copy the class comment to aFileStream. If moveSource is true (as in compressChanges or compressSources, then update classComment to point to the new file." | fileComment | classComment ifNotNil: [aFileStream cr. fileComment _ RemoteString newString: classComment text onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [classComment _ fileComment]]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! moveChangedCommentToFile: aFileStream numbered: fileIndex "If the comment is in the changes file, then move it to a new file." (classComment ~~ nil and: [classComment sourceFileNumber > 1]) ifTrue: [self fileOutCommentOn: aFileStream moveSource: true toFile: fileIndex]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! objectForDataStream: refStrm | dp | "I am about to be written on an object file. Write a path to me in the other system instead." self hasSubject ifTrue: [ (refStrm insideASegment and: [self subject isSystemDefined not]) ifTrue: [ ^ self]. "do trace me" (self subject isKindOf: Class) ifTrue: [ dp _ DiskProxy global: self subject name selector: #organization args: #(). refStrm replace: self with: dp. ^ dp]]. ^ self "in desparation" ! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | classComment ifNotNil: [aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: aClass name; nextPutAll: ' commentStamp: '. commentStamp ifNil: [commentStamp _ '']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! ! !BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'! setSubject: aClassDescription subject _ aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription ^ self new setSubject: aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription defaultList: aSortedCollection | inst | inst _ self defaultList: aSortedCollection. inst setSubject: aClassDescription. ^ inst! ! !BasicInspector methodsFor: 'as yet unclassified' stamp: 'ajh 1/31/2003 15:49'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection." self initialize. object _ anObject. selectionIndex _ 0. contents _ ''! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'! testBecome "Test the two way become. Note. we cannot use string literals for this test" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a = 'cd'; assert: b = 'ab'; assert: c = 'cd'; assert: d = 'ab'. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:28'! testBecomeForward "Test the forward become." | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a becomeForward: b. self assert: a = 'cd'; assert: b = 'cd'; assert: c = 'cd'; assert: d = 'cd'. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 17:36'! testBecomeForwardDontCopyIdentityHash "Check that 1. the argument to becomeForward: is NOT modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b hb | a := 'ab' copy. b := 'cd' copy. hb := b identityHash. a becomeForward: b copyHash: false. self assert: a identityHash = hb; assert: b identityHash = hb. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:29'! testBecomeForwardHash | a b c hb | a := 'ab' copy. b := 'cd' copy. c := a. hb := b hash. a becomeForward: b. self assert: a hash = hb; assert: b hash = hb; assert: c hash = hb. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:27'! testBecomeForwardIdentityHash "Check that 1. the argument to becomeForward: is modified to have the receiver's identity hash. 2. the receiver's identity hash is unchanged." | a b ha | a := 'ab' copy. b := 'cd' copy. ha := a identityHash. a becomeForward: b. self assert: a identityHash = ha; assert: b identityHash = ha. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:30'! testBecomeHash | a b c d ha hb | a := 'ab' copy. b := 'cd' copy. c := a. d := b. ha := a hash. hb := b hash. a become: b. self assert: a hash = hb; assert: b hash = ha; assert: c hash = hb; assert: d hash = ha. ! ! !BecomeTest methodsFor: 'Testing' stamp: 'brp 9/19/2003 15:31'! testBecomeIdentityHash "Note. The identity hash of both objects seems to change after the become:" | a b c d | a := 'ab' copy. b := 'cd' copy. c := a. d := b. a become: b. self assert: a identityHash = c identityHash; assert: b identityHash = d identityHash; deny: a identityHash = b identityHash. ! ! !Beeper methodsFor: 'play interface' stamp: 'gk 2/24/2004 23:25'! play "This is how the default Beeper makes a beep, by sending beep to the default sound service. The sound system will check if sounds are enabled." SoundService default beep! ! !Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! Beeper provides simple audio (or in some other way) feedback to the user. The recommended use is "Beeper beep" to give the user the equivalence of a beep. If you want to force the beep to use the primitive in the VM for beeping, then use "Beeper beepPrimitive". In either case, if sounds are disabled there will be no beep. The actual beeping, when you use "Beeper beep", is done by sending a #play message to a registered playable object. You can register your own playable object by invoking the class side method #setDefault: passing in an object that responds to the #play message. The default playable object is an instance of Beeper itself which implements #play on the instance side. That implementation delegates the playing of the beep to the default SoundService. Note that #play is introduced as a common interface between AbstractSound and Beeper. This way we can register instances of AbstractSound as playable entities, for example: Beeper setDefault: (SampledSound new setSamples: self coffeeCupClink samplingRate: 12000). Then "Beeper beep" will play the coffeeCup sound.! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:51'! clearDefault "Clear the default playable. Will be lazily initialized in Beeper class >>default." default := nil! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:55'! default "When the default is not defined it is initialized using #newDefault." default isNil ifTrue: [default := self newDefault ]. ^ default! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/24/2004 22:12'! newDefault "Subclasses may override me to provide a default beep. This base implementation returns an instance of Beeper which uses the pluggable sound service." ^ self new! ! !Beeper class methodsFor: 'customize' stamp: 'gk 2/22/2004 17:54'! setDefault: aPlayableEntity "Set the playable entity used when making a beep. The playable entity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'! beep "The preferred way of producing an audible feedback. The default playable entity (an instance of Beeper) also uses the pluggable SoundService mechanism, so it will use the primitive beep only if there is no other sound mechanism available." self default play ! ! !Beeper class methodsFor: 'beeping' stamp: 'gk 2/24/2004 08:38'! beepPrimitive "Make a primitive beep. Only use this if you want to force this to be a primitive beep. Otherwise use Beeper class>>beep since this method bypasses the current registered playable entity." Preferences soundsEnabled ifTrue: [ self primitiveBeep]! ! !Beeper class methodsFor: 'private' stamp: 'gk 2/24/2004 23:51'! primitiveBeep "Make a primitive beep. Not to be called directly. It is much better to use Beeper class>>beep or Beeper class>>beepPrimitive since this method bypasses the current registered playable entity and does not check Preferences class>>soundsEnabled." self primitiveFailed! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 11/19/2004 15:18'! emptyMethodDictionary ^ MethodDictionary new! ! !Behavior methodsFor: 'initialize-release' stamp: 'NS 1/28/2004 11:17'! forgetDoIts "get rid of old DoIt methods" self basicRemoveSelector: #DoIt; basicRemoveSelector: #DoItIn:! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName _ self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName _ obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ self environment at: obsName asSymbol! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 11/19/2004 15:19'! obsolete "Invalidate and recycle local messages, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue:[ methodDict _ self emptyMethodDictionary ].! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! ! !Behavior methodsFor: 'accessing' stamp: 'di 3/7/2001 17:05'! methodDict methodDict == nil ifTrue: [self recoverFromMDFaultWithTrace]. ^ methodDict! ! !Behavior methodsFor: 'testing' stamp: 'sw 1/26/2001 20:06'! fullyImplementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to all the messages in aVocabulary" (aVocabulary encompassesAPriori: self) ifTrue: [^ true]. aVocabulary allSelectorsInVocabulary do: [:aSelector | (self canUnderstand: aSelector) ifFalse: [^ false]]. ^ true! ! !Behavior methodsFor: 'testing' stamp: 'sw 5/4/2001 07:44'! implementsVocabulary: aVocabulary "Answer whether instances of the receiver respond to the messages in aVocabulary." (aVocabulary isKindOf: FullVocabulary orOf: ScreenedVocabulary) ifTrue: [^ true]. ^ self fullyImplementsVocabulary: aVocabulary! ! !Behavior methodsFor: 'testing' stamp: 'ab 3/12/2003 17:44'! isMeta ^ false! ! !Behavior methodsFor: 'testing' stamp: 'sd 3/28/2003 15:07'! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(self environment compactClassesArray includes: self) or:[(self environment specialObjectsArray includes: self) or:[self isKindOf: self]]! ! !Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11'! literalScannedAs: scannedLiteral notifying: requestor "Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote). If scannedLiteral is not an association, answer it. Else, if it is of the form: nil->#NameOfMetaclass answer nil->theMetaclass, if any has that name, else report an error. Else, if it is of the form: #NameOfGlobalVariable->anythiEng answer the global, class, or pool association with that nameE, if any, else add it to Undeclared a answer the new Association." | key value | (scannedLiteral isVariableBinding) ifFalse: [^ scannedLiteral]. key _ scannedLiteral key. value _ scannedLiteral value. key isNil ifTrue: "###" [(self bindingOf: value) ifNotNilDo:[:assoc| (assoc value isKindOf: Behavior) ifTrue: [^ nil->assoc value class]]. requestor notify: 'No such metaclass'. ^false]. (key isMemberOf: Symbol) ifTrue: "##" [(self bindingOf: key) ifNotNilDo:[:assoc | ^assoc]. Undeclared at: key put: nil. ^Undeclared bindingOf: key]. requestor notify: '## must be followed by a non-local variable name'. ^false " Form literalScannedAs: 14 notifying: nil 14 Form literalScannedAs: #OneBitForm notiEfying: nil OneBitForm Form literalScannedAs: ##OneBitForm notifying: nil OneBitForm->a Form Form literalScannedAs: ##Form notifying: nil Form->Form Form literalScannedAs: ###Form notifying: nil nilE->Form class "! ! !Behavior methodsFor: 'printing' stamp: 'tk 10/16/2001 19:35'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables. But, not useful for a class with a method dictionary." aStream nextPutAll: '<>'; cr.! ! !Behavior methodsFor: 'printing' stamp: 'ar 5/17/2003 14:11'! storeLiteral: aCodeLiteral on: aStream "Store aCodeLiteral on aStream, changing an Association to ##GlobalName or ###MetaclassSoleInstanceName format if appropriate" | key value | (aCodeLiteral isVariableBinding) ifFalse: [aCodeLiteral storeOn: aStream. ^self]. key _ aCodeLiteral key. (key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass]) ifTrue: [aStream nextPutAll: '###'; nextPutAll: value soleInstance name. ^self]. ((key isMemberOf: Symbol) and: [(self bindingOf: key) notNil]) ifTrue: [aStream nextPutAll: '##'; nextPutAll: key. ^self]. aCodeLiteral storeOn: aStream! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 13:59'! compile: code notifying: requestor "Compile the argument, code, as source code in the context of the receiver and insEtall the result in the receiver's method dictionary. The second argument, requestor, is to be notified if an error occurs. The argument code is either a string or an object that converts to a string or a PositionableStream. This method also saves the source code." | methodAndNode | methodAndNode _ self basicCompile: code "a Text" notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector! ! !Behavior methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:07'! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set" "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. self environment currentProjectDo: [:proj | proj compileAllIsolated: self from: oldClass].! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 11:32'! defaultMethodTrailer ^ #(0 0 0 0)! ! !Behavior methodsFor: 'compiling' stamp: 'ar 8/16/2001 11:44'! recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! ! !Behavior methodsFor: 'compiling' stamp: 'NS 1/28/2004 09:22'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ method trailer. methodNode _ self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self addSelectorSilently: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: 'compiling' stamp: 'ajh 6/11/2001 17:05'! recompileNonResidentMethod: method atSelector: selector from: oldClass "Recompile the method supplied in the context of this class." | trailer methodNode | trailer _ method trailer. methodNode _ self compilerClass new compile: (method getSourceFor: selector in: oldClass) in: self notifying: nil ifFail: ["We're in deep doo-doo if this fails (syntax error). Presumably the user will correct something and proceed, thus installing the result in this methodDict. We must retrieve that new method, and restore the original (or remove) and then return the method we retrieved." ^ self error: 'see comment']. selector == methodNode selector ifFalse: [self error: 'selector changed!!']. ^ methodNode generate: trailer ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable. Essential. See Object documentation whatIsAPrimitive." self isVariable ifTrue: [ ^ self basicNew: 0 ]. "space must be low" self environment signalLowSpace. ^ self basicNew "retry if user proceeds" ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 3/28/2003 15:06'! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." self environment signalLowSpace. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: 'instance creation' stamp: 'Noury Bouraqadi 8/23/2003 14:51'! new "Answer a new initialized instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." ^ self basicNew initialize ! ! !Behavior methodsFor: 'instance creation' stamp: 'sd 5/20/2004 11:20'! new: sizeRequested "Answer an initialized instance of this class with the number of indexable variables specified by the argument, sizeRequested." ^ (self basicNew: sizeRequested) initialize ! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'nb 5/6/2003 17:11'! allSubclasses "Answer a Set of the receiver's and the receiver's descendent's subclasses. " | scan scanTop | scan _ OrderedCollection withAll: self subclasses. scanTop _ 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop _ scanTop + 1]. ^ scan asSet! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:06'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level "Walk the tree of subclasses, giving the class and its level" | subclassNames | classAndLevelBlock value: self value: level. self == Class ifTrue: [^ self]. "Don't visit all the metaclasses" "Visit subclasses in alphabetical order" subclassNames _ SortedCollection new. self subclassesDo: [:subC | subclassNames add: subC name]. subclassNames do: [:name | (self environment at: name) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level+1]! ! !Behavior methodsFor: 'accessing class hierarchy'! allSuperclasses "Answer an OrderedCollection of the receiver's and the receiver's ancestor's superclasses. The first element is the receiver's immediate superclass, followed by its superclass; the last element is Object." | temp | ^ superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp _ superclass allSuperclasses. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'! subclasses "slow implementation since Behavior does not keep trace of subclasses" ^ self class allInstances select: [:each | each superclass = self ]! ! !Behavior methodsFor: 'accessing class hierarchy'! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 09:34'! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:27'! addSelectorSilently: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary. Do this without sending system change notifications" | oldMethodOrNil | oldMethodOrNil _ self lookupSelector: selector. self methodDict at: selector put: compiledMethod. "Now flush Squeak's method cache, either by selector or by method" oldMethodOrNil == nil ifFalse: [oldMethodOrNil flushCache]. selector flushCache.! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 12/12/2003 15:57'! allSelectors "Answer all selectors understood by instances of the receiver" | coll | coll _ OrderedCollection new. self withAllSuperclasses do: [:aClass | coll addAll: aClass selectors]. ^ coll asIdentitySet! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 6/20/2001 15:46'! firstPrecodeCommentFor: selector "If there is a comment in the source code at the given selector that preceeds the body of the method, return it here, else return nil" | parser source tree | "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" (MessageSet isPseudoSelector: selector) ifTrue: ["Not really a selector" ^ nil]. source _ self sourceCodeAt: selector asSymbol ifAbsent: [^ nil]. parser _ self parserClass new. tree _ parser parse: (ReadStream on: source) class: self noPattern: false context: nil notifying: nil ifFail: [^ nil]. ^ (tree comment ifNil: [^ nil]) first! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 8/19/2001 12:45'! "popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc... The syntactic elements are: 1 comment preceding initial selector fragment 2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments) ---------------------- (ends here for, e.g., #copy) 4 first formal argument 5 comment following first formal argument (nil if selector has only one argument) ---------------------- (ends here for, e.g., #copyFrom:) 6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments) ---------------------- (ends here for, e.g., #copyFrom:to:) Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) " Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: " ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'! methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector" | sourceString parser | sourceString _ self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser _ self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) "Behavior methodHeaderFor: #methodHeaderFor: " ! ! !Behavior methodsFor: 'accessing method dictionary'! precodeCommentOrInheritedCommentFor: selector "Answer a string representing the first comment in the method associated with selector, considering however only comments that occur before the beginning of the actual code. If the version recorded in the receiver is uncommented, look up the inheritance chain. Return nil if none found." | aSuper aComment | ^ (aComment _ self firstPrecodeCommentFor: selector) isEmptyOrNil ifTrue: [(self == Behavior or: [superclass == nil or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector] "ActorState precodeCommentOrInheritedCommentFor: #printOn:"] ifFalse: [aComment]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 11:17'! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." ^ self basicRemoveSelector: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'NS 3/4/2004 21:04'! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemChangeNotifier uniqueInstance doSilently: [self removeSelector: selector].! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'rw 5/12/2003 11:19'! selectorAtMethod: method setClass: classResultBlock "Answer both the message selector associated with the compiled method and the class in which that selector is defined." | sel | sel _ self methodDict keyAtIdentityValue: method ifAbsent: [superclass == nil ifTrue: [classResultBlock value: self. ^method defaultSelector]. sel _ superclass selectorAtMethod: method setClass: classResultBlock. "Set class to be self, rather than that returned from superclass. " sel == method defaultSelector ifTrue: [classResultBlock value: self]. ^sel]. classResultBlock value: self. ^sel! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'ar 12/27/2001 22:29'! standardMethodHeaderFor: aSelector | args | args _ (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ]. ! ! !Behavior methodsFor: 'accessing method dictionary'! supermostPrecodeCommentFor: selector "Answer a string representing the precode comment in the most distant superclass's implementation of the selector. Return nil if none found." | aSuper superComment | (self == Behavior or: [superclass == nil or: [(aSuper _ superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment _ aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict _ self emptyMethodDictionary. self class isMeta ifTrue: [self class zapAllMethods]! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'tpr 5/30/2003 13:04'! allSharedPools "Answer a Set of the names of the pools (Dictionaries or SharedPool subclasses) that the receiver and the receiver's ancestors share." ^superclass allSharedPools! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'! allowsSubInstVars "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." ^ true! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectAllInstances "Inpsect all instances of the receiver. 1/26/96 sw" | all allSize prefix | all _ self allInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name]. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name)! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'sw 5/21/2001 22:51'! inspectSubInstances "Inspect all instances of the receiver and all its subclasses. CAUTION - don't do this for something as generic as Object!! 1/26/96 sw" | all allSize prefix | all _ self allSubInstances. (allSize _ all size) == 0 ifTrue: [^ self inform: 'There are no instances of ', self name, ' or any of its subclasses']. prefix _ allSize == 1 ifTrue: ['The lone instance'] ifFalse: ['The ', allSize printString, ' instances']. all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')! ! !Behavior methodsFor: 'testing class hierarchy'! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass." self isWeak ifTrue: [^ ' weakSubclass: ']. ^ self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [ ' variableByteSubclass: '] ifFalse: [ ' variableWordSubclass: ']] ifFalse: [ ' variableSubclass: ']] ifFalse: [ ' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:06'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^superclass bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'! classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:20'! scopeHas: varName ifTrue: aBlock "Obsolete. Kept around for possible spurios senders which we don't know about" (self bindingOf: varName) ifNotNilDo:[:binding| aBlock value: binding. ^true]. ^false! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'! thoroughWhichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal. Dives into the compact literal notation, making it slow but thorough " | who | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteralThorough: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary'! whichClassIncludesSelector: aSymbol "Answer the class on the receiver's superclass chain where the argument, aSymbol (a message selector), will be found. Answer nil if none found." "Rectangle whichClassIncludesSelector: #inspect." (self includesSelector: aSymbol) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 3/28/2003 15:07'! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special _ self environment hasSpecialSelector: literal ifTrueSetByte: [:b | byte _ b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 8/16/2001 13:31'! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteral: literal) or: [specialFlag and: [method scanFor: specialByte]]) ifTrue: [((literal isVariableBinding) not or: [method sendsToSuper not or: [method literals allButLast includes: literal]]) ifTrue: [who add: sel]]]. ^ who! ! !Behavior methodsFor: 'enumerating' stamp: 'apb 7/13/2004 00:40'! allInstancesDo: aBlock "Evaluate the argument, aBlock, for each of the current instances of the receiver. Because aBlock might change the class of inst (for example, using become:), it is essential to compute next before aBlock value: inst." | inst next | self == UndefinedObject ifTrue: [^ aBlock value: nil]. inst _ self someInstance. [inst == nil] whileFalse: [ next _ inst nextInstance. aBlock value: inst. inst _ next]! ! !Behavior methodsFor: 'enumerating' stamp: 'nk 2/14/2001 12:09'! withAllSuperAndSubclassesDoGently: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDoGently: aBlock! ! !Behavior methodsFor: 'user interface' stamp: 'sd 3/28/2003 15:05'! allLocalCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol, anywhere in my class hierarchy." | aSet special byte cls | aSet _ Set new. cls _ self theNonMetaClass. special _ self environment hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. cls withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. cls class withAllSuperAndSubclassesDoGently: [ :class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do: [:sel | sel ~~ #DoIt ifTrue: [aSet add: class name , ' ', sel]]]. ^aSet! ! !Behavior methodsFor: 'user interface' stamp: 'RAA 5/28/2001 12:00'! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 13:59'! basicCompile: code notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file" | methodNode | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. methodNode encoder requestor: requestor. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! !Behavior methodsFor: 'private' stamp: 'NS 1/28/2004 10:29'! basicRemoveSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index _ cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ self environment compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'sd 3/28/2003 15:06'! becomeUncompact | cct index | cct _ self environment compactClassesArray. (index _ self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. "Update instspec so future instances will not be compact" format _ format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! ! !Behavior methodsFor: 'private' stamp: 'sd 11/19/2004 15:13'! setFormat: aFormatInstanceDescription "only use this method with extreme care since it modifies the format of the class ie a description of the number of instance variables and whether the class is compact, variable sized" format := aFormatInstanceDescription ! ! !Behavior methodsFor: 'private' stamp: 'sd 2/1/2004 15:14'! spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space method | space _ 0. self selectorsDo: [:sel | space _ space + 16. "dict and org'n space" method _ self compiledMethodAt: sel. space _ space + (method size + 6 "hdr + avg pad"). method literals do: [:lit | (lit isMemberOf: Array) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space _ space + 12]. (lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]]. ^ space! ! !Behavior methodsFor: 'system startup' stamp: 'tk 10/26/2001 16:06'! startUpFrom: anImageSegment "Override this when a per-instance startUp message needs to be sent. For example, to correct the order of 16-bit non-pointer data when it came from a different endian machine." ^ nil! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'! addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | obs _ ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs _ obs copyWithout: nil. obs _ obs copyWith: aClass. ObsoleteSubclasses at: self put: obs. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'! obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. ^ obs copyWithout: nil! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'! removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | obs _ ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs _ obs copyWithout: aClass. obs _ obs copyWithout: nil. ObsoleteSubclasses at: self put: obs! ! !Behavior methodsFor: 'deprecated' stamp: 'NS 12/12/2003 16:00'! allSelectorsUnderstood "Answer a list of all selectors understood by instances of the receiver" | aList | self deprecated: 'Use allSelectors instead.'. aList _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aList addAll: aClass selectors]. ^ aList asSet asArray "SketchMorph allSelectorsUnderstood size"! ! !Behavior methodsFor: 'deprecated' stamp: 'NS 1/28/2004 11:29'! removeSelectorSimply: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | self deprecated: 'Use basicRemoveSelector: instead.'. oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: '*system-support' stamp: 'tpr 12/17/2003 16:04'! allCallsOn "Answer a SortedCollection of all the methods that refer to me by name or as part of an association in a global dict." ^ (self systemNavigation allCallsOn: (self environment associationAt: self theNonMetaClass name)), (self systemNavigation allCallsOn: self theNonMetaClass name) ! ! !Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! ! !Behavior methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:43'! allUnsentMessages "Answer an array of all the messages defined by the receiver that are not sent anywhere in the system." ^ self environment allUnSentMessagesIn: self selectors! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'! sunitAllSelectors ^self allSelectors asSortedCollection asOrderedCollection! ! !Behavior methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:46'! sunitSelectors ^self selectors asSortedCollection asOrderedCollection! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:23'! flushObsoleteSubclasses "Behavior flushObsoleteSubclasses" ObsoleteSubclasses finalizeValues.! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:51'! initialize "Behavior initialize" "Never called for real" ObsoleteSubclasses ifNil: [self initializeObsoleteSubclasses] ifNotNil: [| newDict | newDict := WeakKeyToCollectionDictionary newFrom: ObsoleteSubclasses. newDict rehash. ObsoleteSubclasses := newDict]! ! !Behavior class methodsFor: 'class initialization' stamp: 'apb 7/12/2004 23:46'! initializeObsoleteSubclasses ObsoleteSubclasses _ WeakKeyToCollectionDictionary new.! ! !Behavior class methodsFor: 'instance creation' stamp: 'sd 11/19/2004 15:27'! new | classInstance | classInstance := self basicNew. classInstance methodDictionary: classInstance emptyMethodDictionary. classInstance superclass: Object. classInstance setFormat: Object format. ^ classInstance! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 3/14/2004 18:11'! testBehaviorSubclasses "self run: #testBehaviorSubclasses" | b b2 | b := Behavior new. b superclass: OrderedCollection. b methodDictionary: MethodDictionary new. self shouldnt: [b subclasses ] raise: Error. self shouldnt: [b withAllSubclasses] raise: Error. self shouldnt: [b allSubclasses] raise: Error. b2 := Behavior new. b2 superclass: b. b2 methodDictionary: MethodDictionary new. self assert: (b subclasses includes: b2). self assert: (b withAllSubclasses includes: b).! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:38'! testBehaviornewnewShouldNotCrash Behavior new new. "still not working correctly but at least does not crash the image" ! ! !BehaviorTest methodsFor: 'tests' stamp: 'sd 11/19/2004 15:54'! testChange "self debug: #testChange" | behavior browser | behavior := Behavior new. behavior superclass: Browser. behavior setFormat: Browser format. browser := Browser new. browser primitiveChangeClassTo: behavior new. behavior compile: 'thisIsATest ^ 2'. self assert: browser thisIsATest = 2. self should: [Browser new thisIsATest] raise: MessageNotUnderstood. ! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:31'! clipBy: aRectangle | aPoint right bottom | right _ clipX + clipWidth. bottom _ clipY + clipHeight. aPoint _ aRectangle origin. aPoint x > clipX ifTrue:[clipX _ aPoint x]. aPoint y > clipY ifTrue:[clipY _ aPoint y]. aPoint _ aRectangle corner. aPoint x < right ifTrue:[right _ aPoint x]. aPoint y < bottom ifTrue:[bottom _ aPoint y]. clipWidth _ right - clipX. clipHeight _ bottom - clipY. clipWidth < 0 ifTrue:[clipWidth _ 0]. clipHeight < 0 ifTrue:[clipHeight _ 0].! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 12/30/2001 20:33'! clipByX1: x1 y1: y1 x2: x2 y2: y2 | right bottom | right _ clipX + clipWidth. bottom _ clipY + clipHeight. x1 > clipX ifTrue:[clipX _ x1]. y1 > clipY ifTrue:[clipY _ y1]. x2 < right ifTrue:[right _ x2]. y2 < bottom ifTrue:[bottom _ y2]. clipWidth _ right - clipX. clipHeight _ bottom - clipY. clipWidth < 0 ifTrue:[clipWidth _ 0]. clipHeight < 0 ifTrue:[clipHeight _ 0].! ! !BitBlt methodsFor: 'accessing' stamp: 'tk 8/15/2001 10:56'! color "Return the current fill color as a Color. Gives the wrong answer if the halftoneForm is a complex pattern of more than one word." halftoneForm ifNil: [^ Color black]. ^ Color colorFromPixelValue: halftoneForm first depth: destForm depth! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/4/2001 15:45'! colorMap: map "See last part of BitBlt comment. 6/18/96 tk" colorMap _ map.! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/14/2001 23:25'! fillColor: aColorOrPattern "The destForm will be filled with this color or pattern of colors. May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form. 6/18/96 tk" aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self]. destForm == nil ifTrue: [self error: 'Must set destForm first']. halftoneForm _ destForm bitPatternFor: aColorOrPattern ! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:38'! halftoneForm "Returns the receivers half tone form. See class commment." ^halftoneForm! ! !BitBlt methodsFor: 'accessing' stamp: 'tbn 9/14/2004 20:39'! halftoneForm: aBitmap "Sets the receivers half tone form. See class commment." halftoneForm := aBitmap ! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form. 6/18/96 tk" | destOrigin | sourceForm _ srcForm. self fillColor: hf. "sets halftoneForm" combinationRule _ rule. destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. srcForm == nil ifFalse: [colorMap _ srcForm colormapIfNeededFor: destForm]. ^ self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:41'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: ["No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255]. ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBits]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBits]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBits]. "Check for unimplmented rules" combinationRule = Form oldPaint ifTrue: [^ self paintBits]. combinationRule = Form oldErase1bitShape ifTrue: [^ self eraseBits]. "Check if BitBlt doesn't support full color maps" (colorMap notNil and:[colorMap isColormap]) ifTrue:[ colorMap _ colorMap colors. ^self copyBits]. "Check if clipping gots us way out of range" self clipRange ifTrue:[^self copyBits]. self error: 'Bad BitBlt arg (Fraction?); proceed to convert.'. "Convert all numeric parameters to integers and try again." destX _ destX asInteger. destY _ destY asInteger. width _ width asInteger. height _ height asInteger. sourceX _ sourceX asInteger. sourceY _ sourceY asInteger. clipX _ clipX asInteger. clipY _ clipY asInteger. clipWidth _ clipWidth asInteger. clipHeight _ clipHeight asInteger. ^ self copyBitsAgain! ! !BitBlt methodsFor: 'copying' stamp: 'ar 2/13/2001 21:12'! copyBitsSimulated ^Smalltalk at: #BitBltSimulation ifPresent:[:bb| bb copyBitsFrom: self].! ! !BitBlt methodsFor: 'copying' stamp: 'nk 4/17/2004 19:42'! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." "Check for compressed source, destination or halftone forms" ((sourceForm isForm) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((destForm isForm) and: [destForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((halftoneForm isForm) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyForm: srcForm to: destPt rule: rule ^ self copyForm: srcForm to: destPt rule: rule colorMap: (srcForm colormapIfNeededFor: destForm)! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/14/2001 23:32'! copyFrom: sourceRectangle in: srcForm to: destPt | sourceOrigin | sourceForm _ srcForm. halftoneForm _ nil. combinationRule _ 3. "store" destX _ destPt x. destY _ destPt y. sourceOrigin _ sourceRectangle origin. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ sourceRectangle width. height _ sourceRectangle height. colorMap _ srcForm colormapIfNeededFor: destForm. self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'yo 5/20/2004 14:30'! displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta destY _ aPoint y. destX _ aPoint x. "the following are not really needed, but theBitBlt primitive will fail if not set" sourceX ifNil: [sourceX _ 100]. width ifNil: [width _ 100]. self primDisplayString: aString from: startIndex to: stopIndex map: font characterToGlyphMap xTable: font xTable kern: kernDelta. ^ destX@destY. ! ! !BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49'! pixelAt: aPoint "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPeekerFromForm:. Returns the pixel at aPoint." sourceX _ aPoint x. sourceY _ aPoint y. destForm unhibernate. "before poking" destForm bits at: 1 put: 0. "Just to be sure" self copyBits. ^ destForm bits at: 1! ! !BitBlt methodsFor: 'copying' stamp: 'ar 3/1/2004 13:49'! pixelAt: aPoint put: pixelValue "Assumes this BitBlt has been set up specially (see the init message, BitBlt bitPokerToForm:. Overwrites the pixel at aPoint." destX _ aPoint x. destY _ aPoint y. sourceForm unhibernate. "before poking" sourceForm bits at: 1 put: pixelValue. self copyBits " | bb | bb _ (BitBlt bitPokerToForm: Display). [Sensor anyButtonPressed] whileFalse: [bb pixelAt: Sensor cursorPoint put: 55] "! ! !BitBlt methodsFor: 'private' stamp: 'ar 3/8/2003 00:34'! clipRange "clip and adjust source origin and extent appropriately" "first in x" | sx sy dx dy bbW bbH | "fill in the lazy state if needed" destX ifNil:[destX := 0]. destY ifNil:[destY := 0]. width ifNil:[width := destForm width]. height ifNil:[height := destForm height]. sourceX ifNil:[sourceX := 0]. sourceY ifNil:[sourceY := 0]. clipX ifNil:[clipX := 0]. clipY ifNil:[clipY := 0]. clipWidth ifNil:[clipWidth := destForm width]. clipHeight ifNil:[clipHeight := destForm height]. destX >= clipX ifTrue: [sx _ sourceX. dx _ destX. bbW _ width] ifFalse: [sx _ sourceX + (clipX - destX). bbW _ width - (clipX - destX). dx _ clipX]. (dx + bbW) > (clipX + clipWidth) ifTrue: [bbW _ bbW - ((dx + bbW) - (clipX + clipWidth))]. "then in y" destY >= clipY ifTrue: [sy _ sourceY. dy _ destY. bbH _ height] ifFalse: [sy _ sourceY + clipY - destY. bbH _ height - (clipY - destY). dy _ clipY]. (dy + bbH) > (clipY + clipHeight) ifTrue: [bbH _ bbH - ((dy + bbH) - (clipY + clipHeight))]. sourceForm ifNotNil:[ sx < 0 ifTrue: [dx _ dx - sx. bbW _ bbW + sx. sx _ 0]. sx + bbW > sourceForm width ifTrue: [bbW _ bbW - (sx + bbW - sourceForm width)]. sy < 0 ifTrue: [dy _ dy - sy. bbH _ bbH + sy. sy _ 0]. sy + bbH > sourceForm height ifTrue: [bbH _ bbH - (sy + bbH - sourceForm height)]. ]. (bbW <= 0 or:[bbH <= 0]) ifTrue:[ sourceX := sourceY := destX := destY := clipX := clipY := width := height := 0. ^true]. (sx = sourceX and:[sy = sourceY and:[dx = destX and:[dy = destY and:[bbW = width and:[bbH = height]]]]]) ifTrue:[^false]. sourceX := sx. sourceY := sy. destX := dx. destY := dy. width := bbW. height := bbH. ^true! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/14/2001 23:43'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor | lastSourceDepth | sourceForm ifNotNil:[lastSourceDepth _ sourceForm depth]. sourceForm _ aStrikeFont glyphs. (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: ["Set up color map for a different source depth (color font)" "Uses caching for reasonable efficiency" colorMap _ self cachedFontColormapFrom: sourceForm depth to: destForm depth. colorMap at: 1 put: (destForm pixelValueFor: backgroundColor)]. sourceForm depth = 1 ifTrue: [colorMap at: 2 put: (destForm pixelValueFor: foregroundColor). "Ignore any halftone pattern since we use a color map approach here" halftoneForm _ nil]. sourceY _ 0. height _ aStrikeFont height. ! ! !BitBlt methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor "Set up the parameters. Since the glyphs in a TTCFont is 32bit depth form, it tries to use rule=34 to get better AA result if possible." ((aTTCFont depth = 32)) ifTrue: [ destForm depth <= 8 ifTrue: [ self colorMap: (self cachedFontColormapFrom: aTTCFont depth to: destForm depth). self combinationRule: Form paint. ] ifFalse: [ self colorMap: nil. self combinationRule: 34. ]. halftoneForm _ nil. sourceY _ 0. height _ aTTCFont height. ]. ! ! !BitBlt methodsFor: 'private' stamp: 'yo 3/11/2005 14:49'! primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta | ascii | startIndex to: stopIndex do:[:charIndex| ascii _ (aString at: charIndex) asciiValue. sourceX _ xTable at: ascii + 1. width _ (xTable at: ascii + 2) - sourceX. self copyBits. destX _ destX + width + kernDelta. ].! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/14/2001 23:32'! setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm _ df. sourceForm _ sf. self fillColor: hf. "sets halftoneForm" combinationRule _ cr. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ extent x. height _ extent y. aPoint _ clipRect origin. clipX _ aPoint x. clipY _ aPoint y. aPoint _ clipRect corner. clipWidth _ aPoint x - clipX. clipHeight _ aPoint y - clipY. sourceForm == nil ifFalse: [colorMap _ sourceForm colormapIfNeededFor: destForm]! ! !BitBlt commentStamp: '' prior: 0! I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 8: if source is 0 and destination is 0 4: if source is 0 and destination is 1 2: if source is 1 and destination is 0 1: if source is 1 and destination is 1. At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! !BitBlt class methodsFor: 'examples' stamp: 'ar 5/4/2001 16:02'! exampleColorMap "BitBlt exampleColorMap" "This example shows what one can do with the fixed part of a color map. The color map, as setup below, rotates the bits of a pixel all the way around. Thus you'll get a (sometime strange looking ;-) animation of colors which will end up exactly the way it looked at the beginning. The example is given to make you understand that the masks and shifts can be used for a lot more than simply color converting pixels. In this example, for instance, we use only two of the four independent shifters." | cc bb | cc _ ColorMap masks: { 1 << (Display depth-1). "mask out high bit of color component" 1 << (Display depth-1) - 1. "mask all other bits" 0. 0} shifts: { 1 - Display depth. "shift right to bottom most position" 1. "shift all other pixels one bit left" 0. 0}. bb _ BitBlt toForm: Display. bb sourceForm: Display; combinationRule: 3; colorMap: cc. 1 to: Display depth do:[:i| bb copyBits. Display forceDisplayUpdate. ]. ! ! !BitBlt class methodsFor: 'examples' stamp: 'dew 9/18/2001 02:30'! exampleOne "This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules). This only works at Display depth of 1. (Rule 15 does not work?)" | path displayDepth | displayDepth _ Display depth. Display newDepth: 1. path _ Path new. 0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]]. Display fillWhite. path _ path translateBy: 60 @ 40. 1 to: 16 do: [:index | BitBlt exampleAt: (path at: index) rule: index - 1 fillColor: nil]. [Sensor anyButtonPressed] whileFalse: []. Display newDepth: displayDepth. "BitBlt exampleOne"! ! !BitBlt class methodsFor: 'examples' stamp: 'jrm 2/21/2001 23:43'! exampleTwo "This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops. This only works at Depth of 1." | f aBitBlt displayDepth | "create a small black Form source as a brush. " displayDepth _ Display depth. Display newDepth: 1. f _ Form extent: 20 @ 20. f fillBlack. "create a BitBlt which will OR gray into the display. " aBitBlt _ BitBlt destForm: Display sourceForm: f fillColor: Color gray combinationRule: Form over destOrigin: Sensor cursorPoint sourceOrigin: 0 @ 0 extent: f extent clipRect: Display computeBoundingBox. "paint the gray Form on the screen for a while. " [Sensor anyButtonPressed] whileFalse: [aBitBlt destOrigin: Sensor cursorPoint. aBitBlt copyBits]. Display newDepth: displayDepth. "BitBlt exampleTwo"! ! !BitBlt class methodsFor: 'private' stamp: 'jrm 2/21/2001 23:45'! exampleAt: originPoint rule: rule fillColor: mask "This builds a source and destination form and copies the source to the destination using the specifed rule and mask. It is called from the method named exampleOne. Only works with Display depth of 1" | s d border aBitBlt | border_Form extent: 32@32. border fillBlack. border fill: (1@1 extent: 30@30) fillColor: Color white. s _ Form extent: 32@32. s fillWhite. s fillBlack: (7@7 corner: 25@25). d _ Form extent: 32@32. d fillWhite. d fillBlack: (0@0 corner: 32@16). s displayOn: Display at: originPoint. border displayOn: Display at: originPoint rule: Form under. d displayOn: Display at: originPoint + (s width @0). border displayOn: Display at: originPoint + (s width @0) rule: Form under. d displayOn: Display at: originPoint + (s extent // (2 @ 1)). aBitBlt _ BitBlt destForm: Display sourceForm: s fillColor: mask combinationRule: rule destOrigin: originPoint + (s extent // (2 @ 1)) sourceOrigin: 0 @ 0 extent: s extent clipRect: Display computeBoundingBox. aBitBlt copyBits. border displayOn: Display at: originPoint + (s extent // (2 @ 1)) rule: Form under. "BitBlt exampleAt: 100@100 rule: 0 fillColor: nil" ! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/24/2001 23:49'! benchDiffsFrom: before to: afterwards "Given two outputs of BitBlt>>benchmark show the relative improvements." | old new log oldLine newLine oldVal newVal improvement | log _ WriteStream on: String new. old _ ReadStream on: before. new _ ReadStream on: afterwards. [old atEnd or:[new atEnd]] whileFalse:[ oldLine _ old upTo: Character cr. newLine _ new upTo: Character cr. (oldLine includes: Character tab) ifTrue:[ oldLine _ ReadStream on: oldLine. newLine _ ReadStream on: newLine. Transcript cr; show: (oldLine upTo: Character tab); tab. log cr; nextPutAll: (newLine upTo: Character tab); tab. [oldLine skipSeparators. newLine skipSeparators. oldLine atEnd] whileFalse:[ oldVal _ Integer readFrom: oldLine. newVal _ Integer readFrom: newLine. improvement _ oldVal asFloat / newVal asFloat roundTo: 0.01. Transcript show: improvement printString; tab; tab. log print: improvement; tab; tab]. ] ifFalse:[ Transcript cr; show: oldLine. log cr; nextPutAll: oldLine. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'! benchmark "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[bb copyBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/14/2001 23:31'! benchmark2 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[1 to: 10 do:[:i| bb copyBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[1 to: 4 do:[:i| bb warpBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 4/26/2001 21:04'! benchmark3 "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededFor: dest). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[1 to: 10 do:[:i| bb copyBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[1 to: 4 do:[:i| bb warpBits]]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside2 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! testDrawingWayOutside3 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside4 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside5 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! testDrawingWayOutside6 | f1 bb f2 | f1 := Form extent: 100@100 depth: 1. f2 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb sourceForm: f2. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. bb sourceOrigin: SmallInteger maxVal squared asPoint. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: 100; height: 100. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside2 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: 0@0. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! testFillingWayOutside3 | f1 bb | f1 := Form extent: 100@100 depth: 1. bb := BitBlt toForm: f1. bb combinationRule: 3. bb fillColor: Color black. bb destOrigin: SmallInteger maxVal squared asPoint. bb width: SmallInteger maxVal squared; height: SmallInteger maxVal squared. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 4/6/2003 19:04'! testAlphaCompositing | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 4/6/2003 19:04'! testAlphaCompositing2 | bb f1 f2 mixColor result eps | f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBits. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].! ! !BitBltTest methodsFor: 'bugs' stamp: 'tpr 8/15/2003 19:00'! testAlphaCompositing2Simulated | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent: [:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color transparent. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBitsSimulated. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: result alpha = mixColor alpha. ].]! ! !BitBltTest methodsFor: 'bugs' stamp: 'tpr 8/15/2003 19:02'! testAlphaCompositingSimulated | bb f1 f2 mixColor result eps | Smalltalk at: #BitBltSimulation ifPresent:[:bitblt| f1 := Form extent: 1@1 depth: 32. f2 := Form extent: 1@1 depth: 32. eps := 0.5 / 255. 0 to: 255 do:[:i| f1 colorAt: 0@0 put: Color blue. mixColor := Color red alpha: i / 255.0. f2 colorAt: 0@0 put: mixColor. mixColor := f2 colorAt: 0@0. bb := BitBlt toForm: f1. bb sourceForm: f2. bb combinationRule: Form blend. bb copyBitsSimulated. result := f1 colorAt: 0@0. self assert: (result red - mixColor alpha) abs < eps. self assert: (result blue - (1.0 - mixColor alpha)) abs < eps. self assert: result alpha = 1.0. ]].! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 3/1/2004 13:49'! testPeekerUnhibernateBug | bitBlt | bitBlt := BitBlt bitPeekerFromForm: Display. bitBlt destForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! ! !BitBltTest methodsFor: 'bugs' stamp: 'ar 3/1/2004 13:49'! testPokerUnhibernateBug | bitBlt | bitBlt := BitBlt bitPokerToForm: Display. bitBlt sourceForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! ! !BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:53'! getCurrentColor | formExtent form c | c := Color colorFromPixelValue: color depth: Display depth. formExtent _ 30@30" min: 10@ 10//(2+1@2)". "compute this better" form _ Form extent: formExtent depth: Display depth. form borderWidth: 5. form border: form boundingBox width: 4 fillColor: Color white. form fill: form boundingBox fillColor: c. ^form! ! !BitEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 13:21'! setColor: aColor "Set the color that the next edited dots of the model to be the argument, aSymbol. aSymbol can be any color changing message understood by a Form, such as white or black." color _ aColor pixelValueForDepth: Display depth. squareForm fillColor: aColor. self changed: #getCurrentColor! ! !BitEditor class methodsFor: 'private' stamp: 'BG 12/4/2003 10:18'! bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView "Create a BitEditor on aForm. That is, aForm is a small image that will change as a result of the BitEditor changing a second and magnified view of me. magnifiedFormLocation is where the magnified form is to be located on the screen. scaleFactor is the amount of magnification. This method implements a scheduled view containing both a small and magnified view of aForm. Upon accept, aForm is updated." | aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent | scaledFormView _ FormHolderView new model: aForm. scaledFormView scaleBy: scaleFactor. bitEditor _ self new. scaledFormView controller: bitEditor. bitEditor setColor: Color black. topView _ ColorSystemView new. remoteView == nil ifTrue: [topView label: 'Bit Editor']. topView borderWidth: 2. topView addSubView: scaledFormView. remoteView == nil ifTrue: "If no remote view, then provide a local view of the form" [aFormView _ FormView new model: scaledFormView workingForm. aFormView controller: NoController new. aForm height < 50 ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2] ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0]. topView addSubView: aFormView below: scaledFormView] ifFalse: "Otherwise, the remote one should view the same form" [remoteView model: scaledFormView workingForm]. lowerRightExtent _ remoteView == nil ifTrue: [(scaledFormView viewport width - aFormView viewport width) @ (aFormView viewport height max: 50)] ifFalse: [scaledFormView viewport width @ 50]. menuView _ self buildColorMenu: lowerRightExtent colorCount: 1. menuView model: bitEditor. menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0. topView addSubView: menuView align: menuView viewport topRight with: scaledFormView viewport bottomRight. extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y) + (4 @ 4). "+4 for borders" topView minimumSize: extent. topView maximumSize: extent. topView translateBy: magnifiedFormLocation. topView insideColor: Color white. ^topView! ! !BitEditor class methodsFor: 'private' stamp: 'BG 12/5/2003 13:40'! buildColorMenu: extent colorCount: nColors "See BitEditor magnifyWithSmall." | menuView form aSwitchView button formExtent highlightForm color leftOffset | menuView _ FormMenuView new. menuView window: (0@0 corner: extent). formExtent _ 30@30 min: extent//(nColors*2+1@2). "compute this better" leftOffset _ extent x-(nColors*2-1*formExtent x)//2. highlightForm _ Form extent: formExtent. highlightForm borderWidth: 4. 1 to: nColors do: [:index | color _ (nColors = 1 ifTrue: [#(black)] ifFalse: [#(black gray)]) at: index. form _ Form extent: formExtent. form fill: form boundingBox fillColor: (Color perform: color). form borderWidth: 5. form border: form boundingBox width: 4 fillColor: Color white. button _ Button new. aSwitchView _ PluggableButtonView on: button getState: #isOn action: #turnOn label: #getCurrentColor. index = 1 ifTrue: [button onAction: [menuView model setColor: Color fromUser. aSwitchView label: menuView model getCurrentColor; displayView ] ] ifFalse: [button onAction: [menuView model setTransparentColor]]. aSwitchView shortcutCharacter: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index); label: form; window: (0@0 extent: form extent); translateBy: (((index - 1) * 2 * form width) + leftOffset)@(form height // 2); borderWidth: 1. menuView addSubView: aSwitchView]. ^ menuView ! ! !Bitmap methodsFor: 'filing' stamp: 'nk 12/31/2003 16:02'! storeBits: startBit to: stopBit on: aStream "Store my bits as a hex string, breaking the lines every 100 bytes or so to comply with the maximum line length limits of Postscript (255 bytes). " | lineWidth | lineWidth := 0. self do: [:word | startBit to: stopBit by: -4 do: [:shift | aStream nextPut: (word >> shift bitAnd: 15) asHexDigit. lineWidth := lineWidth + 1]. (lineWidth > 100) ifTrue: [aStream cr. lineWidth := 0]]. lineWidth > 0 ifTrue: [ aStream cr ].! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:11'! atAllPut: value "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." super atAllPut: value.! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 9/21/2001 23:06'! byteAt: byteAddress put: byte "Insert a byte into a Bitmap. Note that this is a byte address and it is one-order. For repeated use, create an instance of BitBlt and use pixelAt:put:. See Form pixelAt:put: 7/1/96 tk" | longWord shift lowBits longAddr | (byte < 0 or:[byte > 255]) ifTrue:[^self errorImproperStore]. lowBits _ byteAddress - 1 bitAnd: 3. longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1). shift _ (3 - lowBits) * 8. longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self at: longAddr put: longWord. ^ byte! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:18'! byteSize ^self size * 4! ! !Bitmap methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:53'! copyFromByteArray: byteArray "This method should work with either byte orderings" | myHack byteHack | myHack := Form new hackBits: self. byteHack := Form new hackBits: byteArray. SmalltalkImage current isLittleEndian ifTrue: [byteHack swapEndianness]. byteHack displayOn: myHack! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:41'! integerAt: index "Return the integer at the given index" | word | word _ self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:42'! integerAt: index put: anInteger "Store the integer at the given index" | word | anInteger < 0 ifTrue:["word _ 16r100000000 + anInteger" word _ (anInteger + 1) negated bitInvert32] ifFalse:[word _ anInteger]. self basicAt: index put: word. ^anInteger! ! !Bitmap methodsFor: 'as yet unclassified' stamp: 'yo 2/18/2004 18:28'! asByteArray "Faster way to make a byte array from me. copyFromByteArray: makes equal Bitmap." | f bytes hack | f _ Form extent: 4@self size depth: 8 bits: self. bytes _ ByteArray new: self size * 4. hack _ Form new hackBits: bytes. SmalltalkImage current isLittleEndian ifTrue:[hack swapEndianness]. hack copyBits: f boundingBox from: f at: (0@0) clippingBox: hack boundingBox rule: Form over fillColor: nil map: nil. "f displayOn: hack." ^ bytes. ! ! !Bitmap class methodsFor: 'utilities' stamp: 'sd 6/28/2003 09:33'! swapBytesIn: aNonPointerThing from: start to: stop "Perform a bigEndian/littleEndian byte reversal of my words. We only intend this for non-pointer arrays. Do nothing if I contain pointers." | hack blt | "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: aNonPointerThing. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: start-1; destY: start-1; height: stop-start+1; width: 1. blt sourceX: 0; destX: 3; copyBits. "Exchange bytes 0 and 3" blt sourceX: 3; destX: 0; copyBits. blt sourceX: 0; destX: 3; copyBits. blt sourceX: 1; destX: 2; copyBits. "Exchange bytes 1 and 2" blt sourceX: 2; destX: 1; copyBits. blt sourceX: 1; destX: 2; copyBits. ! ! !BitmapBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:21'! testBitmapByteAt | bm | bm := Bitmap new: 1. 1 to: 4 do:[:i| self should:[bm byteAt: i put: 1000] raise: Error. ].! ! !BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:34'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'choose new graphic' translated target: self selector: #chooseNewGraphicIn:event: argument: aMorph. aMenu add: 'grab new graphic' translated target: self selector: #grabNewGraphicIn:event: argument: aMorph. super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! !BitmapFillStyle methodsFor: 'Morphic menu' stamp: 'nk 6/12/2004 09:59'! chooseNewGraphicIn: aMorph event: evt "Used by any morph that can be represented by a graphic" | aGraphicalMenu | aGraphicalMenu := GraphicalMenu new initializeFor: self withForms: aMorph reasonableBitmapFillForms coexist: true. aGraphicalMenu selector: #newForm:forMorph:; argument: aMorph. evt hand attachMorph: aGraphicalMenu! ! !BitmapFillStyle commentStamp: '' prior: 0! A BitmapFillStyle fills using any kind of form. Instance variables: form
The form to be used as fill. tileFlag If true, then the form is repeatedly drawn to fill the area.! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'KLC 1/27/2004 13:33'! fromForm: aForm | fs | fs _ self form: aForm. fs origin: 0@0. fs direction: aForm width @ 0. fs normal: 0 @ aForm height. fs tileFlag: true. ^fs! ! !BitmapStreamTests methodsFor: 'Running' stamp: 'nk 7/5/2003 15:22'! setUp random _ Random new.! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 17:05'! testShortIntegerArrayReadRefStream2 |refStrm| refStrm _ ReferenceStream on: ((RWBinaryOrTextStream with: (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3))) reset; binary). self assert: (refStrm next = (ShortIntegerArray with: 0 with: 1 with: 2 with: 3)).! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:06'! testShortIntegerArrayWithImageSegment array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/17/2004 18:44'! testShortIntegerArrayWithRefStream array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:03'! testShortIntegerArrayWithRefStream2 array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 17 83 104 111 114 116 73 110 116 101 103 101 114 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:22'! testShortIntegerArrayWithRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 16:32'! testShortIntegerArrayWithSmartRefStream array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 3/16/2004 16:04'! testShortIntegerArrayWithSmartRefStream2 array _ ShortIntegerArray with: 0 with: 1 with: 2 with: 3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortIntegerArray' stamp: 'nk 7/5/2003 18:31'! testShortIntegerArrayWithSmartRefStreamOnDisk array _ ShortIntegerArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortInt ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:12'! testShortPointArrayWithImageSegment array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:17'! testShortPointArrayWithRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'! testShortPointArrayWithRefStream2 array _ ShortPointArray with: 0@1 with: 2@3. self validateRefStream. self assert: stream byteStream contents = (ByteArray withAll: #(20 6 15 83 104 111 114 116 80 111 105 110 116 65 114 114 97 121 0 0 0 2 0 0 0 1 0 2 0 3 )) ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:22'! testShortPointArrayWithRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 15:57'! testShortPointArrayWithSmartRefStream array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 3/12/2004 22:07'! testShortPointArrayWithSmartRefStream2 array _ ShortPointArray with: 0@1 with: 2@3. self validateSmartRefStream. self assert: (stream contents asByteArray last: 15) = (ByteArray withAll: #(0 0 0 2 0 0 0 1 0 2 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortPointArray' stamp: 'nk 7/5/2003 18:31'! testShortPointArrayWithSmartRefStreamOnDisk array _ ShortPointArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomShortPoint ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-misc' stamp: 'nk 3/17/2004 16:48'! testOtherClasses #(WordArrayForSegment FloatArray PointArray IntegerArray SoundBuffer String ShortPointArray ShortIntegerArray WordArray Array DependentsArray ByteArray Bitmap ColorArray ) do: [:s | | a | a _ (Smalltalk at: s) new: 3. self assert: (a basicSize * a bytesPerBasicElement = a byteSize). ] ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! createSampleShortRunArray ^ShortRunArray newFrom: { 0. 1. 1. 2. 2. 2. 3. 3. 3. 3 }! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! testShortRunArrayWithImageSegment array _ self createSampleShortRunArray. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! testShortRunArrayWithRefStream array _ self createSampleShortRunArray. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! testShortRunArrayWithRefStreamOnDisk array _ self createSampleShortRunArray. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:39'! testShortRunArrayWithSmartRefStream array _ self createSampleShortRunArray. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:44'! testShortRunArrayWithSmartRefStream2 array _ self createSampleShortRunArray. self validateSmartRefStream. self assert: (stream contents asByteArray last: 23) = (ByteArray withAll: #(0 0 0 4 0 1 0 0 0 2 0 1 0 3 0 2 0 4 0 3 33 13 13)) ! ! !BitmapStreamTests methodsFor: 'tests-ShortRunArray' stamp: 'nk 3/17/2004 16:40'! testShortRunArrayWithSmartRefStreamOnDisk array _ self createSampleShortRunArray. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:23'! testMatrixTransform2x3WithImageSegment array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'! testMatrixTransform2x3WithRefStream array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:24'! testMatrixTransform2x3WithRefStreamOnDisk array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'! testMatrixTransform2x3WithSmartRefStream array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-MatrixTransform2x3' stamp: 'nk 3/7/2004 14:25'! testMatrixTransform2x3WithSmartRefStreamOnDisk array _ MatrixTransform2x3 new. 1 to: 6 do: [ :i | array at: i put: self randomFloat ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:25'! testWordArrayWithImageSegment array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateImageSegment ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:27'! testWordArrayWithSmartRefStream array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStream ! ! !BitmapStreamTests methodsFor: 'tests-WordArray' stamp: 'nk 7/5/2003 18:31'! testWordArrayWithSmartRefStreamOnDisk array _ WordArray new: 10. 1 to: 10 do: [ :i | array at: i put: self randomWord ]. self validateSmartRefStreamOnDisk ! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 3/7/2004 14:22'! randomFloat "Answer a random 32-bit float" | w | random seed: (w _ random nextValue). ^w! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:33'! randomShortInt ^((random next * 65536) - 32768) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:00'! randomShortPoint ^(((random next * 65536) @ (random next * 65536)) - (32768 @ 32768)) truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:26'! randomWord "Answer a random 32-bit integer" | w | random seed: (w _ random nextValue). ^w truncated! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:11'! validateImageSegment "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.extSeg'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. (ImageSegment new copyFromRootsForExport: (Array with: array)) writeForExport: filename. other _ (FileDirectory default readOnlyFileNamed: filename) fileInObjectAndCode. self assert: array = other originalRoots first! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:17'! validateRefStream "array is set up with an array." | other rwstream | rwstream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream _ ReferenceStream on: rwstream. stream nextPut: array; close. rwstream position: 0. stream _ ReferenceStream on: rwstream. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:22'! validateRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ ReferenceStream fileNamed: filename. stream nextPut: array; close. stream _ ReferenceStream fileNamed: filename. other _ stream next. stream close. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 16:43'! validateSmartRefStream "array is set up with an array." | other | stream _ RWBinaryOrTextStream on: (ByteArray new: array basicSize * 6). stream binary. stream fileOutClass: nil andObject: array. stream position: 0. stream binary. other _ stream fileInObjectAndCode. self assert: array = other! ! !BitmapStreamTests methodsFor: 'private' stamp: 'nk 7/5/2003 18:32'! validateSmartRefStreamOnDisk "array is set up with an array." | other filename | filename _ 'bitmapStreamTest.ref'. FileDirectory default deleteFileNamed: filename ifAbsent: [ ]. stream _ FileDirectory default fileNamed: filename. stream fileOutClass: nil andObject: array. stream close. stream _ FileDirectory default fileNamed: filename. other _ stream fileInObjectAndCode. stream close. self assert: array = other! ! !BitmapStreamTests commentStamp: 'nk 3/7/2004 14:26' prior: 0! This is an incomplete test suite for storing and reading various word- and short-word subclasses of ArrayedCollection. It demonstrates some problems with filing in of certain kinds of arrayed objects, including: ShortPointArray ShortIntegerArray ShortRunArray WordArray MatrixTransform2x3 In 3.6b-5331, I get 8 passed/6 failed/6 errors (not counting the MatrixTransform2x3 tests, which were added later). I ran into problems when trying to read back the SqueakLogo flash character morph, after I'd done a 'save morph to disk' from its debug menu. The words within the ShortPointArrays and ShortRunArrays were reversed. ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'! form ^form! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 16:02'! form: aForm form _ aForm! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 16:01'! movieDrawArea ^movieDrawArea! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:54'! mpegLogic ^mpegLogic! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:54'! mpegLogic: aValue mpegLogic _ aValue! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 15:45'! primary ^primary! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 12/19/2000 21:52'! quadNumber ^quadNumber! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 1/4/2001 10:53'! quadNumber: aNumber quadNumber _ aNumber! ! !BlobMPEGMorph methodsFor: 'access' stamp: 'JMM 10/19/2000 15:59'! stream ^0! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:18'! drawOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments. Fill with the MPEG movie" | cm f filled quadRect | cm _ Bitmap new: 2. cm at: 1 put: 0. cm at: 2 put: 32767. f _ Form extent: self extent depth: 16. filled _ self filledForm. (BitBlt toForm: f) sourceForm: filled; sourceRect: filled boundingBox; destRect: (0 @ 0 extent: filled extent); colorMap: cm; combinationRule: Form over; copyBits. quadNumber = 1 ifTrue: [quadRect _ Rectangle origin: form boundingBox topLeft corner: form boundingBox center]. quadNumber = 2 ifTrue: [quadRect _ Rectangle origin: form boundingBox topCenter corner: form boundingBox rightCenter]. quadNumber = 3 ifTrue: [quadRect _ Rectangle origin: form boundingBox leftCenter corner: form boundingBox bottomCenter]. quadNumber = 4 ifTrue: [quadRect _ Rectangle origin: form boundingBox center corner: form boundingBox bottomRight]. (BitBlt toForm: f) sourceForm: form; sourceRect: quadRect; destRect: (0 @ 0 extent: f extent); combinationRule: Form and; copyBits. aCanvas image: f at: self position. self drawBorderOn: aCanvas. self drawArrowsOn: aCanvas! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 1/4/2001 11:07'! playStream: aStream mpegLogic playStream: aStream. ! ! !BlobMPEGMorph methodsFor: 'drawing' stamp: 'JMM 12/19/2000 16:41'! playVideoStream: aStream mpegLogic playVideoStream: aStream. ! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:43'! initialize: primaryFlag mpegPlayer: aMpegPlayerOrFileName | rect sizeToOverLapBoundary | primary := primaryFlag. rect := self bounds. sizeToOverLapBoundary := 3.0. mpegLogic := primary ifTrue: [form := Form extent: ((sizeToOverLapBoundary * rect width) @ (sizeToOverLapBoundary * rect height)) truncated depth: 32. movieDrawArea := SketchMorph withForm: form. MPEGPlayer playFile: aMpegPlayerOrFileName onMorph: movieDrawArea] ifFalse: [form := aMpegPlayerOrFileName form. movieDrawArea := aMpegPlayerOrFileName movieDrawArea. aMpegPlayerOrFileName mpegLogic]! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 11:02'! initializeBlobShape | verts modifier | verts _ {59@40. 74@54. 79@74. 77@93. 57@97. 37@97. 22@83. 15@67. 22@50. 33@35. 47@33}. modifier _ 0 @ 0. (self quadNumber = 2) ifTrue: [ modifier _ 0 @ 75]. (self quadNumber = 3) ifTrue: [ modifier _ 75 @ 0]. (self quadNumber = 4) ifTrue: [ modifier _ 75 @ 75]. verts _ verts + modifier. self vertices: verts color: self color borderWidth: 1 borderColor: Color black! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'! initializeChildMpegPlayer: aMpegPlayerOrFileName self initialize: false mpegPlayer: aMpegPlayerOrFileName ! ! !BlobMPEGMorph methodsFor: 'initialization' stamp: 'JMM 1/4/2001 10:54'! initializePrimaryMpegPlayer: aMpegPlayerOrFileName self initialize: true mpegPlayer: aMpegPlayerOrFileName ! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 10/19/2000 15:57'! adjustColors ^self! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:39'! limitRange: verts " limit radius to range 20-120; limit interpoint angle to surrounding angles with max of twice of average separation. " | cent new prevn nextn prevDeg nextDeg thisDeg dincr | cent := self bounds center. new := Array new: verts size. dincr := 360 // verts size. verts doWithIndex: [ :pt :n | "Find prev/next points, allowing for wrapping around " prevn := n-1 < 1 ifTrue: [new size] ifFalse: [n-1]. nextn := n+1 > new size ifTrue: [1] ifFalse: [n+1]. "Get prev/this/next point's angles " prevDeg := ((verts at: prevn)-cent) degrees. thisDeg := ((verts at: n)-cent) degrees. nextDeg := ((verts at: nextn)-cent) degrees. "Adjust if this is where angles wrap from 0 to 360" (thisDeg - prevDeg) abs > 180 ifTrue: [ prevDeg := prevDeg - 360 ]. (thisDeg - nextDeg) abs > 180 ifTrue: [ nextDeg := nextDeg + 360 ]. "Put adjusted point into new collection" new at: n put: cent + (self selfPolarPointRadius: ((((pt - cent) r) min: 60) max: 20) "was min: 80" degrees: (((thisDeg min: nextDeg-5) max: prevDeg+5) min: dincr*2+prevDeg)) ]. ^ new ! ! !BlobMPEGMorph methodsFor: 'stepping' stamp: 'JMM 12/19/2000 15:29'! mergeBlobs ^self! ! !BlobMPEGMorph methodsFor: 'testing' stamp: 'JMM 10/19/2000 16:29'! stepTime ^1.0 / (self mpegLogic videoFrameRate: self stream) * 1000! ! !BlobMPEGMorph commentStamp: '' prior: 0! Ok this is a little follow on to David's BlobMorph. Why not embedded a movie in the blob I thought. So with a few minutes of help from John Maloney we have something very interesting. Enjoy John M McIntosh Dec 2000. (Christmas early)! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:10'! buildMorphics: aFileName | primary child | primary _ (self basicNew quadNumber: 1) initialize. self remember: primary. primary initializePrimaryMpegPlayer: aFileName. primary openInWorld. 2 to: 4 do: [:i | child _ (self basicNew quadNumber: i) initialize. self remember: child. child initializeChildMpegPlayer: primary. child openInWorld]. ^primary ! ! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:11'! newWithMovie: aFileName | primary | primary _ self buildMorphics: aFileName. primary playStream: 0. ^primary ! ! !BlobMPEGMorph class methodsFor: 'instance creation' stamp: 'JMM 1/4/2001 11:12'! newWithMovieNoSound: aFileName | primary | primary _ self buildMorphics: aFileName. primary playVideoStream: 0. ^primary ! ! !BlobMorph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:06'! setConstrainedPosition: aPoint hangOut: partiallyOutside "Deal with dragging the blob over another blob which results in spontaneous deletations." self owner ifNil: [^ self]. super setConstrainedPosition: aPoint hangOut: false. "note that we keep them from overlapping"! ! !BlobMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ random next < 0.25 ifTrue: [Color random] ifFalse: [Color random alpha: random next * 0.4 + 0.4]! ! !BlobMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:42'! initialize "initialize the state of the receiver" random _ Random new. sneaky _ random next < 0.75. super initialize. "" self beSmoothCurve; initializeBlobShape; setVelocity! ! !BlobMorph methodsFor: 'stepping' stamp: 'ccn 8/28/2001 20:51'! mergeBlobs "See if we need to merge by checking our bounds against all other Blob bounds, then all our vertices against any Blob with overlapping bounds. If we find a need to merge, then someone else does all the work." (AllBlobs isNil or: [AllBlobs size < 2]) ifTrue: [^ self]. AllBlobs do: [:aBlob | aBlob owner == self owner ifTrue: [(self bounds intersects: aBlob bounds) ifTrue: [vertices do: [:aPoint | (aBlob containsPoint: aPoint) ifTrue: [^ self mergeSelfWithBlob: aBlob atPoint: aPoint]]]]] without: self! ! !BlobMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'! descriptionForPartsBin ^ self partName: 'Blob' categories: #('Demo') documentation: 'A patch of primordial slime'! ! !BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'! setUp morph := BlobMorph new.! ! !BlobMorphTest methodsFor: 'initialize-release' stamp: 'md 4/21/2003 16:26'! tearDown morph delete.! ! !BlobMorphTest methodsFor: 'testing' stamp: 'md 4/21/2003 16:26'! testOpenInWorld self shouldnt: [morph openInWorld] raise: Error.! ! !BlobMorphTest commentStamp: '' prior: 0! This is the unit test for the class BlobMorph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome ^ deadHome! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome _ context! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 6/24/2004 03:50'! env: aClosureEnvironment "the outer environment" environment _ aClosureEnvironment! ! !BlockClosure methodsFor: 'initializing' stamp: 'ajh 5/28/2001 18:37'! method: compiledMethod "compiledMethod will be the code I execute when I'm evaluated" method _ compiledMethod! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! copyForSaving "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/16/2002 18:32'! fixTemps "obsolete"! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 1/31/2003 12:53'! reentrant! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 7/15/2001 16:13'! valueError self error: 'Incompatible number of args'! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 7/26/2002 11:47'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess _ Processor activeProcess. oldPriority _ activeProcess priority. activeProcess priority: Processor highestPriority. result _ self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! !BlockClosure methodsFor: 'private' stamp: 'ajh 6/24/2004 03:34'! veryDeepInner: deepCopier "Do not copy my method (which can be shared because CompiledMethod2 are basically treated as immutables) or my home context (MethodContexts are treated as immutables too)" super veryDeepInner: deepCopier. method _ method. environment _ environment. ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:02'! bench "See how many times I can value in 5 seconds. I'll answer a meaningful description." | startTime endTime count | count _ 0. endTime _ Time millisecondClockValue + 5000. startTime _ Time millisecondClockValue. [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count _ count + 1 ]. endTime _ Time millisecondClockValue. ^count = 1 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] ifFalse: [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:03'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:04'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/15/2001 15:57'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value "Evaluate the block with no args. Fail if the block expects other than 0 arguments." ^ environment executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value: arg1 "Evaluate the block with the given args. Fail if the block expects other than 1 arguments." ^ environment with: arg1 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:43'! value: arg1 value: arg2 "Evaluate the block with the given args. Fail if the block expects other than 2 arguments." ^ environment with: arg1 with: arg2 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! value: arg1 value: arg2 value: arg3 "Evaluate the block with the given args. Fail if the block expects other than 3 arguments." ^ environment with: arg1 with: arg2 with: arg3 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! value: arg1 value: arg2 value: arg3 value: arg4 "Evaluate the block with the given args. Fail if the block expects other than 4 arguments." ^ environment with: arg1 with: arg2 with: arg3 with: arg4 executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 7/19/2004 14:42'! valueWithArguments: anArray "Evaluate the block with given args. Fail if the block expects other than the given number of arguments." ^ environment withArgs: anArray executeMethod: method! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 14:44'! valueWithPossibleArgs: anArray | n | (n _ self numArgs) = 0 ifTrue: [^ self value]. n = anArray size ifTrue: [^ self valueWithArguments: anArray]. ^ self valueWithArguments: (n > anArray size ifTrue: [anArray, (Array new: n - anArray size)] ifFalse: [anArray copyFrom: 1 to: n])! ! !BlockClosure methodsFor: 'evaluating' stamp: 'md 10/14/2004 17:03'! valueWithPossibleArgument: anArg "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils." self numArgs = 0 ifTrue: [^self value]. self numArgs = 1 ifTrue: [^self value: anArg]. self numArgs > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs - 1)]! ! !BlockClosure methodsFor: 'evaluating' stamp: 'ar 2/23/2005 11:48'! valueWithin: aDuration onTimeout: timeoutBlock "Evaluate the receiver. If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" | theProcess delay watchdog done result | aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. "the block will be executed in the current process" theProcess := Processor activeProcess. delay := aDuration asDelay. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" done ifFalse: [ theProcess signalException: TimedOut ] ] newProcess. "watchdog needs to run at high priority to do its job" watchdog priority: Processor timingPriority. "catch the timeout signal" ^ [ done := false. watchdog resume. "start up the watchdog" result := self value. "evaluate the receiver" done := true. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" result ] on: TimedOut do: [ :e | timeoutBlock value ]. ! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 6/24/2004 03:40'! env ^ environment! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:24'! hasLiteralSuchThat: testBlock (testBlock value: method) ifTrue: [^ true]. ^ method hasLiteralSuchThat: testBlock! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/31/2003 16:59'! hasLiteralThorough: literal "Answer true if literal is identical to any literal imbedded in my method" method == literal ifTrue: [^ true]. ^ method hasLiteralThorough: literal! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 2/6/2003 13:27'! hasMethodReturn "Answer whether the receiver has a return ('^') in its code." ^ self method remoteReturns! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/21/2001 14:01'! method ^ method! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 5/28/2001 14:37'! numArgs ^ method numArgs! ! !BlockClosure methodsFor: 'controlling' stamp: 'md 10/14/2004 17:04'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result _ self value. conditionBlock value] whileFalse. ^ result! ! !BlockClosure methodsFor: 'controlling' stamp: 'md 10/14/2004 17:04'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result _ self value. conditionBlock value] whileTrue. ^ result! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeat "Evaluate the receiver repeatedly, ending only if the block explicitly returns." [self value. true] whileTrue! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! repeatWithGCIf: testBlock | ans | "run the receiver, and if testBlock returns true, garbage collect and run the receiver again" ans _ self value. (testBlock value: ans) ifTrue: [ Smalltalk garbageCollect. ans _ self value ]. ^ans! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is false." ^ [self value] whileFalse: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileFalse: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is false." ^ [self value] whileFalse: [aBlock value]! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the receiver, as long as its value is true." ^ [self value] whileTrue: []! ! !BlockClosure methodsFor: 'controlling' stamp: 'ajh 7/15/2001 16:03'! whileTrue: aBlock "Ordinarily compiled in-line, and therefore not overridable. This is in case the message is sent to other than a literal block. Evaluate the argument, aBlock, as long as the value of the receiver is true." ^ [self value] whileTrue: [aBlock value]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/15/2001 16:14'! assert self assert: self! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 5/20/2004 17:37'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b _ aBlock. thisContext tempAt: 1 put: nil. "aBlock _ nil" b value. ]. ^ returnValue! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/21/2003 17:50'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 2/1/2003 00:30'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | "just a marker, fail and execute the following" handlerActive _ true. ^ self value! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 1/31/2003 20:41'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockClosure methodsFor: 'exceptions' stamp: 'ajh 7/26/2002 11:49'! valueUninterruptably "Prevent remote returns from escaping the sender. Even attempts to terminate (unwind) this process will be halted and the process will resume here. A terminate message is needed for every one of these in the sender chain to get the entire process unwound." ^ self ifCurtailed: [^ self]! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 6/24/2004 03:43'! asContext "Create a MethodContext that is ready to execute self. Assumes self takes no args (if it does the args will be nil)" ^ MethodContext sender: nil receiver: environment method: method arguments: #()! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 1/27/2003 18:51'! callCC "Call with current continuation, ala Scheme. Evaluate self against a copy of the sender's call stack, which can be resumed later" ^ self value: thisContext sender asContinuation! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/15/2001 16:03'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process while self runs" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 9/29/2001 21:00'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." ^ self newProcess priority: priority; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'md 10/14/2004 17:04'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'md 10/14/2004 17:05'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^ Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockClosure methodsFor: 'scheduling' stamp: 'ajh 7/27/2002 12:26'! simulate "Like run except interpret self using Smalltalk instead of VM. It is much slower." ^ self newProcess simulate! ! !BlockClosure methodsFor: 'printing' stamp: 'ajh 9/10/2002 16:53'! printOn: aStream super printOn: aStream. aStream space; nextPutAll: self identityHashPrintString! ! !BlockClosure methodsFor: '*sunit-preload' stamp: 'rw 1/23/2002 00:27'! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockClosure methodsFor: '*sunit-preload' stamp: 'rw 1/23/2002 00:28'! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !BlockClosure methodsFor: 'comparing' stamp: 'ajh 6/24/2004 03:56'! = other self class == other class ifFalse: [^ false]. self env = other env ifFalse: [^ false]. ^ self method = other method! ! !BlockClosure methodsFor: 'comparing' stamp: 'ajh 10/4/2002 17:12'! hash ^ method hash! ! !BlockClosure commentStamp: 'ajh 7/19/2004 14:57' prior: 0! A BlockClosure is a block of Smalltalk code (enclosed within []) that may be executed later by sending #valueWithArguments: (or one of its variants) to it. A block can take arguments by specifying the names of the arguments in the beginning of the block, as in "[:arg1 :arg2 | ...]", and can have its own local temps, as in "[:arg1 | | temp1 temp2 | ...]". The block may reference variables outside its scope directly by name. It also may return from its home context by using ^, otherwise, the value of the last statement is returned to the sender of valueWithArguments:. Structure: method CompiledMethod2 Contains the block's code. It has its own method separate from its home method. environment ClosureEnvironment | Object The lexical environment the block was created in. The environment only contains variables that were captured/reference by this block or other sister blocks. If only self and/or its instance variables are captured then the environment is simply the receiver object. Each non-inlined blocks has its own CompiledMethod. These block methods are held in the literals of the home method and sent the #createBlock: message at runtime to create BlockClosures. Home method temps captured by inner blocks are placed inside a ClosureEnvironment when the home method is started. This environment is supplied as the argument to each #createBlock:. When #value... is sent to a block closure, its method is executed in a new MethodContext with its closure environment as the receiver. The block method accesses its free variables (captured home temps) via this environment. Closure environments are nested mirroring the nesting of blocks. Each environment points to its parent environment (the top method environment has no parent). However, for efficiency, environments that have no captured temps are skipped (never created). For example, an environment's parent may actually be its grand-parent. There is no special parent variable in ClosureEnvironment, it is just another named variable such as 'self' or 'parent env' (special var with space so it can't be referenced by user code), or it may not be their at all. A block closure that returns to its home context does so by finding the thisContext sender that owns the top environment. A return inside a block forces the home environment to be created even if it has no captured temps. Each context holds its local environment (which holds its captured temps) in its #myEnv instance variable (previously the unused #receiverMap variable). Code that references captured temps goes through the #myEnv context variable. Block closures are totally separate from their home context. They are reentrant and each activation has its own block-local temps. So except for the thisContext psuedo-variable, contexts are now LIFO (assuming we get rid of old block contexts and recompile the whole image). ! !BlockContext methodsFor: 'initialize-release' stamp: 'ajh 7/18/2003 21:49'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." pc _ startpc. self stackp: 0. nargs timesRepeat: [ "skip arg popping" self nextInstruction selector = #popIntoTemporaryVariable: ifFalse: [self halt: 'unexpected bytecode instruction'] ]. ! ! !BlockContext methodsFor: 'accessing' stamp: 'RAH 4/25/2000 19:49'! argumentCount "Answers the number of arguments needed to evaluate the receiver." #Valuable. ^ self numArgs! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/24/2003 12:35'! blockHome ^ self home! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 23:29'! finalBlockHome ^ self home! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 12:12'! isExecutingBlock ^ true! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'! isMethodContext ^ false! ! !BlockContext methodsFor: 'accessing' stamp: 'mdr 4/10/2001 10:34'! numArgs "Answer the number of arguments that must be used to evaluate this block" ^nargs! ! !BlockContext methodsFor: 'accessing' stamp: 'ajh 1/30/2003 15:45'! reentrant "Copy before calling so multiple activations can exist" ^ self copy! ! !BlockContext methodsFor: 'evaluating' stamp: 'cmm 2/16/2003 16:08'! bench "See how many times I can value in 5 seconds. I'll answer a meaningful description." | startTime endTime count | count _ 0. endTime _ Time millisecondClockValue + 5000. startTime _ Time millisecondClockValue. [ Time millisecondClockValue > endTime ] whileFalse: [ self value. count _ count + 1 ]. endTime _ Time millisecondClockValue. ^count = 1 ifTrue: [ ((endTime - startTime) // 1000) printString, ' seconds.' ] ifFalse: [ ((count * 1000) / (endTime - startTime)) asFloat printString, ' per second.' ]! ! !BlockContext methodsFor: 'evaluating' stamp: 'brp 9/25/2003 13:49'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !BlockContext methodsFor: 'evaluating' stamp: 'ajh 1/13/2002 13:36'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver, and normally return it's value. If an error occurs, the errorHandlerBlock is evaluated, and it's value is instead returned. The errorHandlerBlock must accept zero, one, or two parameters (the error message and the receiver)." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | 'huh?']. [1 / 0] ifError: [:err :rcvr | 'ZeroDivide' = err ifTrue: [Float infinity] ifFalse: [self error: err]] " ^ self on: Error do: [:ex | errorHandlerBlock valueWithPossibleArgs: {ex description. ex receiver}]! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSupplyingAnswer: anObject ^ (anObject isCollection and: [anObject isString not]) ifTrue: [self valueSupplyingAnswers: {anObject}] ifFalse: [self valueSupplyingAnswers: {{'*'. anObject}}]! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 11/10/2004 18:43'! valueSupplyingAnswers: aListOfPairs "evaluate the block using a list of questions / answers that might be called upon to automatically respond to Object>>confirm: or FillInTheBlank requests" ^ [self value] on: ProvideAnswerNotification do: [:notify | | answer caption | caption _ notify messageText withSeparatorsCompacted. "to remove new lines" answer _ aListOfPairs detect: [:each | caption = each first or: [caption includesSubstring: each first caseSensitive: false] or: [each first match: caption]] ifNone: [nil]. answer ifNotNil: [notify resume: answer second] ifNil: [ | outerAnswer | outerAnswer _ ProvideAnswerNotification signal: notify messageText. outerAnswer ifNil: [notify resume] ifNotNil: [notify resume: outerAnswer]]]! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/10/2004 22:28'! valueSuppressingAllMessages ^ self valueSuppressingMessages: #('*')! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:59'! valueSuppressingMessages: aListOfStrings ^ self valueSuppressingMessages: aListOfStrings supplyingAnswers: #()! ! !BlockContext methodsFor: 'evaluating' stamp: 'jrp 10/4/2004 18:58'! valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! !BlockContext methodsFor: 'evaluating' stamp: 'mjr 9/10/2003 22:42'! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." self numArgs = anArray size ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] ifFalse: [self error: 'This block accepts ' ,self numArgs printString, ' argument', (self numArgs = 1 ifTrue:[''] ifFalse:['s']) , ', but was called with ', anArray size printString, '.'] ! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:24'! valueWithPossibleArgs: anArray "Evaluate the block represented by the receiver. If the block requires arguments, take them from anArray. If anArray is too large, the rest is ignored, if it is too small, use nil for the other arguments" self numArgs = 0 ifTrue: [^self value]. self numArgs = anArray size ifTrue: [^self valueWithArguments: anArray]. self numArgs > anArray size ifTrue: [ ^self valueWithArguments: anArray, (Array new: (self numArgs - anArray size)) ]. ^self valueWithArguments: (anArray copyFrom: 1 to: self numArgs) ! ! !BlockContext methodsFor: 'evaluating' stamp: 'md 10/7/2004 15:26'! valueWithPossibleArgument: anArg "Evaluate the block represented by the receiver. If the block requires one argument, use anArg, if it requires more than one, fill up the rest with nils." self numArgs = 0 ifTrue: [^self value]. self numArgs = 1 ifTrue: [^self value: anArg]. self numArgs > 1 ifTrue: [^self valueWithArguments: {anArg}, (Array new: self numArgs - 1)]! ! !BlockContext methodsFor: 'evaluating' stamp: 'ar 2/23/2005 11:48'! valueWithin: aDuration onTimeout: timeoutBlock "Evaluate the receiver. If the evaluation does not complete in less than aDuration evaluate the timeoutBlock instead" | theProcess delay watchdog done result | aDuration <= Duration zero ifTrue: [^ timeoutBlock value ]. "the block will be executed in the current process" theProcess := Processor activeProcess. delay := aDuration asDelay. "make a watchdog process" watchdog := [ delay wait. "wait for timeout or completion" done ifFalse: [ theProcess signalException: TimedOut ] ] newProcess. "watchdog needs to run at high priority to do its job" watchdog priority: Processor timingPriority. "catch the timeout signal" ^ [ done := false. watchdog resume. "start up the watchdog" result := self value. "evaluate the receiver" done := true. "it has completed, so ..." delay delaySemaphore signal. "arrange for the watchdog to exit" result ] on: TimedOut do: [ :e | timeoutBlock value ]. ! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:45'! doWhileFalse: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is false." | result | [result _ self value. conditionBlock value] whileFalse. ^ result! ! !BlockContext methodsFor: 'controlling' stamp: 'jf 9/3/2003 16:39'! doWhileTrue: conditionBlock "Evaluate the receiver once, then again as long the value of conditionBlock is true." | result | [result _ self value. conditionBlock value] whileTrue. ^ result! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:23'! asContext ^ self! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 10/16/2002 11:14'! forkAndWait "Suspend current process and execute self in new process, when it completes resume current process" | semaphore | semaphore _ Semaphore new. [self ensure: [semaphore signal]] fork. semaphore wait. ! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkAt: priority named: name "Create and schedule a Process running the code in the receiver at the given priority and having the given name. Answer the newly created process." | forkedProcess | forkedProcess := self newProcess. forkedProcess priority: priority. forkedProcess name: name. ^ forkedProcess resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'svp 6/23/2003 10:59'! forkNamed: aString "Create and schedule a Process running the code in the receiver and having the given name." ^ self newProcess name: aString; resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^Process forContext: [self value. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockContext methodsFor: 'scheduling' stamp: 'ajh 2/10/2003 14:25'! newProcessWith: anArray "Answer a Process running the code in the receiver. The receiver's block arguments are bound to the contents of the argument, anArray. The process is not scheduled." "Simulation guard" ^Process forContext: [self valueWithArguments: anArray. Processor terminateActive] asContext priority: Processor activePriority! ! !BlockContext methodsFor: 'scheduling' stamp: 'sr 6/14/2004 15:19'! valueAt: blockPriority "Evaluate the receiver (block), with another priority as the actual one and restore it afterwards. The caller should be careful with using higher priorities." | activeProcess result outsidePriority | activeProcess := Processor activeProcess. outsidePriority := activeProcess priority. activeProcess priority: blockPriority. result := self ensure: [activeProcess priority: outsidePriority]. "Yield after restoring lower priority to give the preempted processes a chance to run." blockPriority > outsidePriority ifTrue: [Processor yield]. ^ result! ! !BlockContext methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'! blockReturnTop "Simulate the interpreter's action when a ReturnTopOfStack bytecode is encountered in the receiver." | save dest | save _ home. "Needed because return code will nil it" dest _ self return: self pop from: self. home _ save. sender _ nil. ^ dest! ! !BlockContext methodsFor: 'printing' stamp: 'LC 1/6/2002 11:59'! decompile ^ Decompiler new decompileBlock: self! ! !BlockContext methodsFor: 'printing' stamp: 'LC 1/6/2002 13:07'! fullPrintOn: aStream aStream print: self; cr. (self decompile ifNil: ['--source missing--']) fullPrintOn: aStream ! ! !BlockContext methodsFor: 'printing' stamp: 'dew 11/11/2003 01:15'! printOn: aStream | blockString truncatedBlockString | home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil']. aStream nextPutAll: '[] in '. super printOn: aStream. aStream nextPutAll: ' '. blockString _ ((self decompile ifNil: ['--source missing--']) printString replaceAll: Character cr with: Character space) replaceAll: Character tab with: Character space. truncatedBlockString _ blockString truncateWithElipsisTo: 80. truncatedBlockString size < blockString size ifTrue: [truncatedBlockString _ truncatedBlockString, ']}']. aStream nextPutAll: truncatedBlockString. ! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/24/2003 20:36'! aboutToReturn: result through: firstUnwindContext "Called from VM when an unwindBlock is found between self and its home. Return to home's sender, executing unwind blocks on the way." self home return: result! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy _ self copy. (dict at: self home ifAbsentPut: [OrderedCollection new]) add: copy. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !BlockContext methodsFor: 'private' stamp: 'ajh 7/7/2004 13:43'! myEnv "polymorphic with MethodContext" ^ nil! ! !BlockContext methodsFor: 'private' stamp: 'ajh 1/27/2003 21:08'! privHome: context home _ context! ! !BlockContext methodsFor: 'private' stamp: 'ar 3/2/2001 01:16'! valueUnpreemptively "Evaluate the receiver (block), without the possibility of preemption by higher priority processes. Use this facility VERY sparingly!!" "Think about using Block>>valueUninterruptably first, and think about using Semaphore>>critical: before that, and think about redesigning your application even before that!! After you've done all that thinking, go right ahead and use it..." | activeProcess oldPriority result | activeProcess _ Processor activeProcess. oldPriority _ activeProcess priority. activeProcess priority: Processor highestPriority. result _ self ensure: [activeProcess priority: oldPriority]. "Yield after restoring priority to give the preempted processes a chance to run" Processor yield. ^result! ! !BlockContext methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 18:03'! stepToSendOrReturn pc = startpc ifTrue: [ "pop args first" self numArgs timesRepeat: [self step]]. ^super stepToSendOrReturn! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 3/4/2004 22:36'! ensure: aBlock "Evaluate a termination block after evaluating the receiver, regardless of whether the receiver's evaluation completes." | returnValue b | returnValue := self value. "aBlock wasn't nil when execution of this method began; it is nil'd out by the unwind machinery, and that's how we know it's already been evaluated ... otherwise, obviously, it needs to be evaluated" aBlock == nil ifFalse: [ "nil out aBlock temp before evaluating aBlock so it is not executed again if aBlock remote returns" b _ aBlock. thisContext tempAt: 1 put: nil. "aBlock _ nil" b value. ]. ^ returnValue! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:43'! ifCurtailed: aBlock "Evaluate the receiver with an abnormal termination action." ^ self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ar 3/6/2001 14:25'! on: exception do: handlerAction "Evaluate the receiver in the scope of an exception handler." | handlerActive | handlerActive _ true. ^self value! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 10/9/2001 16:51'! onDNU: selector do: handleBlock "Catch MessageNotUnderstood exceptions but only those of the given selector (DNU stands for doesNotUnderstand:)" ^ self on: MessageNotUnderstood do: [:exception | exception message selector = selector ifTrue: [handleBlock valueWithPossibleArgs: {exception}] ifFalse: [exception pass] ]! ! !BlockContext methodsFor: 'exceptions' stamp: 'ajh 1/24/2003 21:53'! valueUninterruptably "Temporarily make my home Context unable to return control to its sender, to guard against circumlocution of the ensured behavior." ^ self ifCurtailed: [^ self]! ! !BlockContext methodsFor: 'private-exceptions' stamp: 'ar 3/9/2001 01:18'! ifProperUnwindSupportedElseSignalAboutToReturn "A really ugly hack to simulate the necessary unwind behavior for VMs not having proper unwind support" "The above indicates new EH primitives supported. In this case is identical to #value. Sender is expected to use [nil] ifProperUnwindSupportedElseSignalAboutToReturn." ^ExceptionAboutToReturn signal.! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:56'! sunitEnsure: aBlock ^self ensure: aBlock! ! !BlockContext methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'! sunitOn: anException do: aHandlerBlock ^self on: anException do: aHandlerBlock! ! !BlockContextTest methodsFor: 'testing - evaluating' stamp: 'tlk 5/31/2004 17:14'! testValueWithArguments self should: [aBlockContext valueWithArguments: #(1 )] raise: Error. self shouldnt: [aBlockContext valueWithArguments: #()] raise: Error. [aBlockContext valueWithArguments: #(1 )] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 0 arguments, but was called with 1.']. [[:i | 3 + 4] valueWithArguments: #(1 2)] ifError: [:err :rcvr | self assert: err = 'Error: This block accepts 1 argument, but was called with 2.']! ! !BlockContextTest methodsFor: 'testing - evaluating' stamp: 'md 10/7/2004 13:52'! testValueWithPossibleArgs | block blockWithArg blockWith2Arg | block := [1]. blockWithArg := [:arg | arg]. blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. self assert: (block valueWithPossibleArgs: #()) = 1. self assert: (block valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #()) = nil. self assert: (blockWithArg valueWithPossibleArgs: #(1)) = 1. self assert: (blockWithArg valueWithPossibleArgs: #(1 2)) = 1. self assert: (blockWith2Arg valueWithPossibleArgs: #()) = {nil .nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1)) = {1 . nil}. self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2)) = #(1 2). self assert: (blockWith2Arg valueWithPossibleArgs: #(1 2 3)) = #(1 2). ! ! !BlockContextTest methodsFor: 'testing - evaluating' stamp: 'md 10/7/2004 13:59'! testValueWithPossibleArgument | block blockWithArg blockWith2Arg | block := [1]. blockWithArg := [:arg | arg]. blockWith2Arg := [:arg1 :arg2 | {arg1. arg2}]. self assert: (block valueWithPossibleArgument: 1) = 1. self assert: (blockWithArg valueWithPossibleArgument: 1) = 1. self assert: (blockWith2Arg valueWithPossibleArgument: 1) = {1 . nil}. ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 14:00'! testBlockIsBottomContext self should: [aBlockContext client ] raise: Error. "block's sender is nil, a block has no client" self assert: aBlockContext bottomContext = aBlockContext. self assert: aBlockContext secondFromBottom isNil.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:49'! testCopyStack self assert: aBlockContext copyStack printString = aBlockContext printString.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:55'! testFindContextSuchThat self assert: (aBlockContext findContextSuchThat: [:each| true]) printString = aBlockContext printString. self assert: (aBlockContext hasContext: aBlockContext). ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:13'! testNew self should: [ContextPart new: 5] raise: Error. [ContextPart new: 5] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart new] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. [ContextPart basicNew] ifError: [:error :receiver | error = 'Error: Contexts must only be created with newForMethod:']. ! ! !BlockContextTest methodsFor: 'testing' stamp: 'mjr 8/24/2003 18:27'! testNoArguments [10 timesRepeat: [:arg | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 1 arguments.']. [10 timesRepeat: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'testing' stamp: 'mjr 8/24/2003 18:25'! testOneArgument | c | c _ OrderedCollection new. c add: 'hello'. [c do: [1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 0 arguments.']. [c do: [:arg1 :arg2 | 1 + 2]] ifError: [:err :rcvr | self deny: err = 'This block requires 2 arguments.'] ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:50'! testRunSimulated self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 13:59'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self deny: aBlockContext isBlockClosure. self deny: aBlockContext isMethodContext. self deny: aBlockContext isPseudoContext. self deny: aBlockContext isDead. self assert: aBlockContext home = contextOfaBlockContext. self assert: aBlockContext blockHome = contextOfaBlockContext. self assert: aBlockContext receiver = self. self assert: (aBlockContext method isKindOf: CompiledMethod). self assert: aBlockContext methodNode selector = 'setUp'. self assert: (aBlockContext methodNodeFormattedAndDecorated: true) selector = 'setUp'.! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:29'! testSupplyAnswerOfFillInTheBlank self should: ['blue' = ([FillInTheBlank request: 'Your favorite color?'] valueSupplyingAnswer: #('Your favorite color?' 'blue'))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:30'! testSupplyAnswerOfFillInTheBlankUsingDefaultAnswer self should: ['red' = ([FillInTheBlank request: 'Your favorite color?' initialAnswer: 'red'] valueSupplyingAnswer: #('Your favorite color?' #default))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/10/2004 22:19'! testSupplyAnswerThroughNestedBlocks self should: [true = ([[self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:27'! testSupplyAnswerUsingOnlySubstringOfQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('like' false))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/10/2004 22:31'! testSupplyAnswerUsingRegexMatchOfQuestion (String includesSelector: #matchesRegex:) ifFalse: [^ self]. self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('.*Smalltalk\?' true))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/10/2004 22:17'! testSupplyAnswerUsingTraditionalMatchOfQuestion self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('*Smalltalk#' true))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:25'! testSupplySameAnswerToAllQuestions self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: true)]. self should: [#(true true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswer: true)].! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:39'! testSupplySeveralAnswersToSeveralQuestions self should: [#(false true) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' false) ('Two' true) ))]. self should: [#(true false) = ([{self confirm: 'One'. self confirm: 'Two'}] valueSupplyingAnswers: #( ('One' true) ('Two' false) ))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:26'! testSupplySpecificAnswerToQuestion self should: [false = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('You like Smalltalk?' false))]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/4/2004 19:35'! testSuppressInform self should: [[nil inform: 'Should not see this message or this test failed!!'] valueSuppressingAllMessages isNil]! ! !BlockContextTest methodsFor: 'testing' stamp: 'jrp 10/10/2004 22:29'! testSuppressInformUsingStringMatchOptions self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('Should not see this message or this test failed!!')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('not see this message')) isNil]. self should: [([nil inform: 'Should not see this message or this test failed!!'] valueSuppressingMessages: #('*message*failed#')) isNil]. ! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:32'! testTallyInstructions self assert: (ContextPart tallyInstructions: aBlockContext) size = 17.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:30'! testTallyMethods self assert: (ContextPart tallyMethods: aBlockContext) size = 4.! ! !BlockContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 12:48'! testTrace self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! !BlockContextTest methodsFor: 'setup' stamp: 'tlk 5/31/2004 12:36'! setUp super setUp. aBlockContext _ [100@100 corner: 200@200]. contextOfaBlockContext _ thisContext.! ! !BlockContextTest commentStamp: 'jrp 10/17/2004 12:22' prior: 0! I am an SUnit Test of BlockContext and its supertype ContextPart. See also MethodContextTest. My fixtures are: aBlockContext - just some trivial block, i.e., [100@100 corner: 200@200]. NOTES ABOUT AUTOMATING USER INPUTS When executing non-interactive programs you will inevitably run into programs (like SqueakMap or Monticello installation packages -- and other programs, to be fair) that require user input during their execution and these sort of problems shoot the whole non-interactiveness of your enclosing program. BlockContext helper methods have been made available and tests of these helpers are provided in this class to demonstrate that it can intercept PopUpMenu and FillInTheBlankMorph requests for user interaction. Of course, PopUpMenu and FillInTheBlankMorph were modified to first signal a ProvideAnswerNotification and if someone handles that (e.g. the enclosing block) then the user interaction will be circumvented and the provided answer of the enclosing block will be used. The basic syntax looks like: [self confirm: 'Install spyware?'] valueSupplyingAnswer: #('Install spyware?' false) There a few variants on this theme making it easy to provide a literal list of answers for the block so that you can handle a bunch of questions in a block with appropriate answers. Additionally, it is possible to suppress Object>>inform: modal dialog boxes as these get in the way of automating anything. After applying this changeset you should be able to tryout the following code snippets to see the variants on this theme that are available. Examples: So you don't need any introduction here -- this one works like usual. [self inform: 'hello'. #done] value. Now let's suppress all inform: messages. [self inform: 'hello'; inform: 'there'. #done] valueSuppressingAllMessages. Here we can just suppress a single inform: message. [self inform: 'hi'; inform: 'there'. #done] valueSuppressingMessages: #('there') Here you see how you can suppress a list of messages. [self inform: 'hi'; inform: 'there'; inform: 'bill'. #done] valueSuppressingMessages: #('hi' 'there') Enough about inform:, let's look at confirm:. As you see this one works as expected. [self confirm: 'You like Squeak?'] value Let's supply answers to one of the questions -- check out the return value. [{self confirm: 'You like Smalltalk?'. self confirm: 'You like Squeak?'}] valueSupplyingAnswer: #('You like Smalltalk?' true) Here we supply answers using only substrings of the questions (for simplicity). [{self confirm: 'You like Squeak?'. self confirm: 'You like MVC?'}] valueSupplyingAnswers: #( ('Squeak' true) ('MVC' false) ) This time let's answer all questions exactly the same way. [{self confirm: 'You like Squeak?'. self confirm: 'You like Morphic?'}] valueSupplyingAnswer: true And, of course, we can answer FillInTheBlank questions in the same manner. [FillInTheBlank request: 'What day is it?'] valueSupplyingAnswer: 'the first day of the rest of your life' We can also return whatever the initialAnswer of the FillInTheBlank was by using the #default answer. [FillInTheBlank request: 'What day is it?' initialAnswer: DateAndTime now dayOfWeekName] valueSupplyingAnswer: #default Finally, you can also do regex matches on any of the question text (or inform text) (should you have VB-Regex enhancements in your image). [FillInTheBlank request: 'What day is it?'] valueSupplyingAnswers: { {'What day.*\?'. DateAndTime now dayOfWeekName} }! !BlockNode methodsFor: 'initialize-release' stamp: 'hmm 7/15/2001 22:23'! arguments: argNodes statements: statementsCollection returns: returnBool from: encoder sourceRange: range "Compile." encoder noteSourceRange: range forNode: self. ^self arguments: argNodes statements: statementsCollection returns: returnBool from: encoder! ! !BlockNode methodsFor: 'code generation' stamp: 'hmm 7/17/2001 21:02'! emitForValue: stack on: aStream aStream nextPut: LdThisContext. stack push: 1. nArgsNode emitForValue: stack on: aStream. remoteCopyNode emit: stack args: 1 on: aStream. "Force a two byte jump." self emitLong: size code: JmpLong on: aStream. stack push: arguments size. arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream]. self emitForEvaluatedValue: stack on: aStream. self returns ifFalse: [ aStream nextPut: EndRemote. pc _ aStream position. ]. stack pop: 1! ! !BlockNode methodsFor: 'tiles' stamp: 'RAA 2/27/2001 09:48'! asMorphicCollectSyntaxIn: parent ^parent blockNodeCollect: self arguments: arguments statements: statements! ! !BlockNode methodsFor: 'tiles' stamp: 'RAA 2/16/2001 09:08'! asMorphicSyntaxIn: parent ^parent blockNode: self arguments: arguments statements: statements! ! !BlockNode class methodsFor: 'instance creation' stamp: 'yo 5/17/2004 23:03'! withJust: aNode ^ self statements: (OrderedCollection with: aNode) returns: false! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 12/12/2001 15:36'! cardsOrPages "The turnable and printable entities" ^ pages! ! !BookMorph methodsFor: 'caching' stamp: 'tk 3/11/2002 12:05'! releaseCachedState "Release the cached state of all my pages." super releaseCachedState. self removeProperty: #allText. "the cache for text search" pages do: [:page | page == currentPage ifFalse: [page fullReleaseCachedState]]. ! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 23:10'! fromRemoteStream: strm "Make a book from an index and a bunch of pages on a server. NOT showing any page!! Index and pages must live in the same directory. If the book has moved, save the current correct urls for each of the pages. Self must already have a url stored in property #url." | remote dict bookUrl oldStem stem oldUrl endPart | remote := strm fileInObjectAndCode. bookUrl := (SqueakPage new) url: (self valueOfProperty: #url); url. "expand a relative url" oldStem := SqueakPage stemUrl: (remote second) url. oldStem := oldStem copyUpToLast: $/. stem := SqueakPage stemUrl: bookUrl. stem := stem copyUpToLast: $/. oldStem = stem ifFalse: ["Book is in new directory, fix page urls" 2 to: remote size do: [:ii | oldUrl := (remote at: ii) url. endPart := oldUrl copyFrom: oldStem size + 1 to: oldUrl size. (remote at: ii) url: stem , endPart]]. self initialize. pages := OrderedCollection new. 2 to: remote size do: [:ii | pages add: (remote at: ii)]. currentPage fullReleaseCachedState; delete. "the blank one" currentPage := remote second. dict := remote first. self setProperty: #modTime toValue: (dict at: #modTime). dict at: #allText ifPresent: [:val | self setProperty: #allText toValue: val]. dict at: #allTextUrls ifPresent: [:val | self setProperty: #allTextUrls toValue: val]. #(#color #borderWidth #borderColor #pageSize) with: #(#color: #borderWidth: #borderColor: #pageSize:) do: [:key :sel | dict at: key ifPresent: [:val | self perform: sel with: val]]. ^self! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:09'! initialize "initialize the state of the receiver" super initialize. "" self setInitialState. pages _ OrderedCollection new. self showPageControls. self class turnOffSoundWhile: [self insertPage]! ! !BookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:07'! setInitialState self listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 5. pageSize _ 160 @ 300. self enableDragNDrop! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 9/21/2003 17:45'! deletePage | message | message _ 'Are you certain that you want to delete this page and everything that is on it? ' translated. (self confirm: message) ifTrue: [self deletePageBasic]. ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:10'! insertPage: aPage pageSize: aPageSize atIndex: anIndex | sz predecessor | sz := aPageSize ifNil: [currentPage isNil ifTrue: [pageSize] ifFalse: [currentPage extent]] ifNotNil: [aPageSize]. aPage extent: sz. (pages isEmpty | anIndex isNil or: [anIndex > pages size]) ifTrue: [pages add: aPage] ifFalse: [anIndex <= 1 ifTrue: [pages addFirst: aPage] ifFalse: [predecessor := anIndex isNil ifTrue: [currentPage] ifFalse: [pages at: anIndex]. self pages add: aPage after: predecessor]]. self goToPageMorph: aPage! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11'! insertPageColored: aColor "Insert a new page for the receiver, using the given color as its background color" | sz newPage bw bc | bc := currentPage isNil ifTrue: [sz := pageSize. bw := 0. Color blue muchLighter] ifFalse: [sz := currentPage extent. bw := currentPage borderWidth. currentPage borderColor]. newPagePrototype ifNil: [newPage := (PasteUpMorph new) extent: sz; color: aColor. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage := newPage)] ifFalse: [pages add: newPage after: currentPage]. self nextPage! ! !BookMorph methodsFor: 'insert and delete' stamp: 'dgd 2/21/2003 23:11'! insertPageSilentlyAtEnd "Create a new page at the end of the book. Do not turn to it." | sz newPage bw bc cc | cc := currentPage isNil ifTrue: [sz := pageSize. bw := 0. bc := Color blue muchLighter. color] ifFalse: [sz := currentPage extent. bw := currentPage borderWidth. bc := currentPage borderColor. currentPage color]. newPagePrototype ifNil: [newPage := (PasteUpMorph new) extent: sz; color: cc. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage := newPagePrototype veryDeepCopy]]. newPage setNameTo: self defaultNameStemForNewPages. newPage vResizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage := newPage) "had been none"] ifFalse: [pages add: newPage after: pages last]. ^newPage! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:13'! addBookMenuItemsTo: aMenu hand: aHandMorph | controlsShowing subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu add: 'previous page' translated action: #previousPage. subMenu add: 'next page' translated action: #nextPage. subMenu add: 'goto page' translated action: #goToPage. subMenu add: 'insert a page' translated action: #insertPage. subMenu add: 'delete this page' translated action: #deletePage. controlsShowing _ self hasSubmorphWithProperty: #pageControl. controlsShowing ifTrue: [subMenu add: 'hide page controls' translated action: #hidePageControls. subMenu add: 'fewer page controls' translated action: #fewerPageControls] ifFalse: [subMenu add: 'show page controls' translated action: #showPageControls]. self isInFullScreenMode ifTrue: [ subMenu add: 'exit full screen' translated action: #exitFullScreen. ] ifFalse: [ subMenu add: 'show full screen' translated action: #goFullScreen. ]. subMenu addLine. subMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:. subMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:. subMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:. subMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:. subMenu addLine. subMenu add: 'sort pages' translated action: #sortPages:. subMenu add: 'uncache page sorter' translated action: #uncachePageSorter. (self hasProperty: #dontWrapAtEnd) ifTrue: [subMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true] ifFalse: [subMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false]. subMenu addLine. subMenu add: 'search for text' translated action: #textSearch. (aHandMorph pasteBuffer class isKindOf: PasteUpMorph class) ifTrue: [subMenu add: 'paste book page' translated action: #pasteBookPage]. subMenu add: 'send all pages to server' translated action: #savePagesOnURL. subMenu add: 'send this page to server' translated action: #saveOneOnURL. subMenu add: 'reload all from server' translated action: #reload. subMenu add: 'copy page url to clipboard' translated action: #copyUrl. subMenu add: 'keep in one file' translated action: #keepTogether. subMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype. newPagePrototype ifNotNil: [subMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype]. aMenu add: 'book...' translated subMenu: subMenu ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:03'! bookmarkForThisPage "If this book exists on a server, make the reference via a URL" | bb url um | (url _ self url) ifNil: [ bb _ SimpleButtonMorph new target: self. bb actionSelector: #goToPageMorph:fromBookmark:. bb label: 'Bookmark' translated. bb arguments: (Array with: currentPage with: bb). self primaryHand attachMorph: bb. ^ bb]. currentPage url ifNil: [currentPage saveOnURLbasic]. um _ URLMorph newForURL: currentPage url. um setURL: currentPage url page: currentPage sqkPage. (SqueakPage stemUrl: url) = (SqueakPage stemUrl: currentPage url) ifTrue: [um book: true] ifFalse: [um book: url]. "remember which book" um isBookmark: true; label: 'Bookmark' translated. um borderWidth: 1; borderColor: #raised. um color: (Color r: 0.4 g: 0.8 b: 0.6). self primaryHand attachMorph: um. ^ um! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:04'! buildThreadOfProjects | thisPVM projectNames threadName | projectNames _ pages collect: [ :each | (thisPVM _ each findA: ProjectViewMorph) ifNil: [ nil ] ifNotNil: [ {thisPVM project name}. ]. ]. projectNames _ projectNames reject: [ :each | each isNil]. threadName _ FillInTheBlank request: 'Please name this thread.' translated initialAnswer: ( self valueOfProperty: #nameOfThreadOfProjects ifAbsent: ['Projects on Parade' translated] ). threadName isEmptyOrNil ifTrue: [^self]. InternalThreadNavigationMorph know: projectNames as: threadName; openThreadNamed: threadName atIndex: nil. ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:05'! copyUrl "Copy this page's url to the clipboard" | str | str _ currentPage url ifNil: [str _ 'Page does not have a url. Send page to server first.' translated]. Clipboard clipboardText: str asText. ! ! !BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17'! findText: keys inStrings: rawStrings startAt: startIndex container: oldContainer pageNum: pageNum "Call once to search a page of the book. Return true if found and highlight the text. oldContainer should be NIL. (oldContainer is only non-nil when (1) doing a 'search again' and (2) the page is in memory and (3) keys has just one element. oldContainer is a TextMorph.)" | good thisWord index insideOf place container start wasIn strings old | good := true. start := startIndex. strings := oldContainer ifNil: ["normal case" rawStrings] ifNotNil: [(pages at: pageNum) isInMemory ifFalse: [rawStrings] ifTrue: [(pages at: pageNum) allStringsAfter: oldContainer]]. keys do: [:searchString | "each key" good ifTrue: [thisWord := false. strings do: [:longString | (index := longString findString: searchString startingAt: start caseSensitive: false) > 0 ifTrue: [thisWord not & (searchString == keys first) ifTrue: [insideOf := longString. place := index]. thisWord := true]. start := 1]. "only first key on first container" good := thisWord]]. good ifTrue: ["all are on this page" wasIn := (pages at: pageNum) isInMemory. self goToPage: pageNum. wasIn ifFalse: ["search again, on the real current text. Know page is in." ^self findText: keys inStrings: ((pages at: pageNum) allStringsAfter: nil) startAt: startIndex container: oldContainer pageNum: pageNum "recompute"]]. (old := self valueOfProperty: #searchContainer) ifNotNil: [(old respondsTo: #editor) ifTrue: [old editor selectFrom: 1 to: 0. "trying to remove the previous selection!!" old changed]]. good ifTrue: ["have the exact string object" (container := oldContainer) ifNil: [container := self highlightText: keys first at: place in: insideOf] ifNotNil: [container userString == insideOf ifFalse: [container := self highlightText: keys first at: place in: insideOf] ifTrue: [(container isTextMorph) ifTrue: [container editor selectFrom: place to: keys first size - 1 + place. container changed]]]. self setProperty: #searchContainer toValue: container. self setProperty: #searchOffset toValue: place. self setProperty: #searchKey toValue: keys. "override later" ActiveHand newKeyboardFocus: container. ^true]. ^false! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:06'! getStemUrl "Try to find the old place where this book was stored. Confirm with the user. Else ask for new place." | initial pg url knownURL | knownURL _ false. initial _ ''. (pg _ currentPage valueOfProperty: #SqueakPage) ifNotNil: [pg contentsMorph == currentPage ifTrue: [initial _ pg url. knownURL _ true]]. "If this page has a url" pages doWithIndex: [:aPage :ind | initial isEmpty ifTrue: [aPage isInMemory ifTrue: [(pg _ aPage valueOfProperty: #SqueakPage) ifNotNil: [initial _ pg url]]]]. "any page with a url" initial isEmpty ifTrue: [initial _ ServerDirectory defaultStemUrl , '1.sp']. "A new legal place" url _ knownURL ifTrue: [initial] ifFalse: [FillInTheBlank request: 'url of the place to store a typical page in this book. Must begin with file:// or ftp://' translated initialAnswer: initial]. ^ SqueakPage stemUrl: url! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 12:59'! goToPage | pageNum | pageNum _ FillInTheBlank request: 'Page?' translated initialAnswer: '0'. pageNum isEmptyOrNil ifTrue: [^true]. self goToPage: pageNum asNumber. ! ! !BookMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:17'! highlightText: stringToHilite at: index in: insideOf "Find the container with this text and highlight it. May not be able to do it for stringMorphs." "Find the container with that text" | container | self allMorphsDo: [:sub | insideOf == sub userString ifTrue: [container := sub]]. container ifNil: [self allMorphsDo: [:sub | insideOf = sub userString ifTrue: [container := sub]]]. "any match" container ifNil: [^nil]. "Order it highlighted" (container isTextMorph) ifTrue: [container editor selectFrom: index to: stringToHilite size - 1 + index]. container changed. ^container! ! !BookMorph methodsFor: 'menu' stamp: 'sw 3/3/2004 18:40'! invokeBookMenu "Invoke the book's control panel menu." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Book' translated. aMenu addStayUpItem. aMenu add: 'find...' translated action: #textSearch. aMenu add: 'go to page...' translated action: #goToPage. aMenu addLine. aMenu addList: { {'sort pages' translated. #sortPages}. {'uncache page sorter' translated. #uncachePageSorter}}. (self hasProperty: #dontWrapAtEnd) ifTrue: [aMenu add: 'wrap after last page' translated selector: #setWrapPages: argument: true] ifFalse: [aMenu add: 'stop at last page' translated selector: #setWrapPages: argument: false]. aMenu addList: { {'make bookmark' translated. #bookmarkForThisPage}. {'make thumbnail' translated. #thumbnailForThisPage}}. aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls. aMenu addUpdating: #showingFullScreenString action: #toggleFullScreen. aMenu addLine. aMenu add: 'sound effect for all pages' translated action: #menuPageSoundForAll:. aMenu add: 'sound effect this page only' translated action: #menuPageSoundForThisPage:. aMenu add: 'visual effect for all pages' translated action: #menuPageVisualForAll:. aMenu add: 'visual effect this page only' translated action: #menuPageVisualForThisPage:. aMenu addLine. (self primaryHand pasteBuffer class isKindOf: PasteUpMorph class) ifTrue: [aMenu add: 'paste book page' translated action: #pasteBookPage]. aMenu add: 'save as new-page prototype' translated action: #setNewPagePrototype. newPagePrototype ifNotNil: [ aMenu add: 'clear new-page prototype' translated action: #clearNewPagePrototype]. aMenu add: (self dragNDropEnabled ifTrue: ['close dragNdrop'] ifFalse: ['open dragNdrop']) translated action: #toggleDragNDrop. aMenu add: 'make all pages this size' translated action: #makeUniformPageSize. aMenu addUpdating: #keepingUniformPageSizeString target: self action: #toggleMaintainUniformPageSize. aMenu addLine. aMenu add: 'send all pages to server' translated action: #savePagesOnURL. aMenu add: 'send this page to server' translated action: #saveOneOnURL. aMenu add: 'reload all from server' translated action: #reload. aMenu add: 'copy page url to clipboard' translated action: #copyUrl. aMenu add: 'keep in one file' translated action: #keepTogether. aMenu addLine. aMenu add: 'load PPT images from slide #1' translated action: #loadImagesIntoBook. aMenu add: 'background color for all pages...' translated action: #setPageColor. aMenu add: 'make a thread of projects in this book' translated action: #buildThreadOfProjects. aMenu popUpEvent: self world activeHand lastEvent in: self world ! ! !BookMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 09:23'! loadImagesIntoBook "PowerPoint stores GIF presentations as individual slides named Slide1, Slide2, etc. Load these into the book. mjg 9/99" | directory filenumber form newpage | directory := ((StandardFileMenu oldFileFrom: FileDirectory default) ifNil: [^nil]) directory. directory isNil ifTrue: [^nil]. "Start loading 'em up!!" filenumber := 1. [directory fileExists: 'Slide' , filenumber asString] whileTrue: [Transcript show: 'Slide' , filenumber asString; cr. Smalltalk bytesLeft < 1000000 ifTrue: ["Make some room" (self valueOfProperty: #url) isNil ifTrue: [self savePagesOnURL] ifFalse: [self saveAsNumberedURLs]]. form := Form fromFileNamed: (directory fullNameFor: 'Slide' , filenumber asString). newpage := PasteUpMorph new extent: form extent. newpage addMorph: (World drawingClass withForm: form). self pages addLast: newpage. filenumber := filenumber + 1]. "After adding all, delete the first page." self goToPage: 1. self deletePageBasic. "Save the book" (self valueOfProperty: #url) isNil ifTrue: [self savePagesOnURL] ifFalse: [self saveAsNumberedURLs]! ! !BookMorph methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'! makeUniformPageSize "Make all pages be of the same size as the current page." currentPage ifNil: [^ Beeper beep]. self resizePagesTo: currentPage extent. newPagePrototype ifNotNil: [newPagePrototype extent: currentPage extent]! ! !BookMorph methodsFor: 'menu' stamp: 'gk 2/23/2004 21:08'! menuPageSoundFor: target event: evt | tSpec menu | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: 'Choose a sound (it is now ' , tSpec first , ')') defaultTarget: target. SoundService default sampledSoundChoices do: [:soundName | menu add: soundName target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (tSpec copy at: 1 put: soundName; yourself))]. menu popUpEvent: evt in: self world! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:39'! menuPageVisualFor: target event: evt | tSpec menu subMenu directionChoices | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: ('Choose an effect (it is now {1})' translated format:{tSpec second asString translated})) defaultTarget: target. TransitionMorph allEffects do: [:effect | directionChoices _ TransitionMorph directionsForEffect: effect. directionChoices isEmpty ifTrue: [menu add: effect asString translated target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: #none))] ifFalse: [subMenu _ MenuMorph new. directionChoices do: [:dir | subMenu add: dir asString translated target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: dir))]. menu add: effect asString translated subMenu: subMenu]]. menu popUpEvent: evt in: self world! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:14'! reload "Fetch the pages of this book from the server again. For all pages that have not been modified, keep current ones. Use new pages. For each, look up in cache, if time there is equal to time of new, and its in, use the current morph. Later do fancy things when a page has changed here, and also on the server." | url onServer onPgs sq which | (url _ self valueOfProperty: #url) ifNil: ["for .bo index file" url _ FillInTheBlank request: 'url of the place where this book''s index is stored. Must begin with file:// or ftp://' translated initialAnswer: (self getStemUrl, '.bo'). url notEmpty ifTrue: [self setProperty: #url toValue: url] ifFalse: [^ self]]. onServer _ self class new fromURL: url. "Later: test book times?" onPgs _ onServer pages collect: [:out | sq _ SqueakPageCache pageCache at: out url ifAbsent: [nil]. (sq notNil and: [sq contentsMorph isInMemory]) ifTrue: [((out sqkPage lastChangeTime > sq lastChangeTime) or: [sq contentsMorph isNil]) ifTrue: [SqueakPageCache atURL: out url put: out sqkPage. out] ifFalse: [sq contentsMorph]] ifFalse: [SqueakPageCache atURL: out url put: out sqkPage. out]]. which _ (onPgs findFirst: [:pg | pg url = currentPage url]) max: 1. self newPages: onPgs currentIndex: which. "later stay at current page" self setProperty: #modTime toValue: (onServer valueOfProperty: #modTime). self setProperty: #allText toValue: (onServer valueOfProperty: #allText). self setProperty: #allTextUrls toValue: (onServer valueOfProperty: #allTextUrls). ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12'! reserveUrls "Save a dummy version of the book first, assign all pages URLs, write dummy files to reserve the url, and write the index. Good when I have pages with interpointing bookmarks." | stem | (stem := self getStemUrl) isEmpty ifTrue: [^self]. pages doWithIndex: [:pg :ind | "does write the current page too" pg url ifNil: [pg reserveUrl: stem , ind printString , '.sp']] "self saveIndexOnURL."! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12'! saveAsNumberedURLs "Write out all pages in this book that are not showing, onto a server. The local disk could be the server. For any page that does not have a SqueakPage and a url already, name that page file by its page number. Any pages that are already totally out will stay that way." | stem list firstTime | firstTime := (self valueOfProperty: #url) isNil. stem := self getStemUrl. "user must approve" stem isEmpty ifTrue: [^self]. firstTime ifTrue: [self setProperty: #futureUrl toValue: stem , '.bo']. self reserveUrlsIfNeeded. pages doWithIndex: [:aPage :ind | "does write the current page too" aPage isInMemory ifTrue: ["not out now" aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. aPage saveOnURL: stem , ind printString , '.sp']]. list := pages collect: [:aPage | aPage sqkPage prePurge]. "knows not to purge the current page" list := (list select: [:each | each notNil]) asArray. "do bulk become:" (list collect: [:each | each contentsMorph]) elementsExchangeIdentityWith: (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). self saveIndexOnURL. self presenter ifNotNil: [self presenter flushPlayerListCache]. firstTime ifTrue: ["Put a thumbnail into the hand" URLMorph grabForBook: self. self setProperty: #futureUrl toValue: nil "clean up"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:16'! saveIndexOfOnly: aPage "Modify the index of this book on a server. Read the index, modify the entry for just this page, and write back. See saveIndexOnURL. (page file names must be unique even if they live in different directories.)" | mine sf remoteFile strm remote pageURL num pre index after dict allText allTextUrls fName | mine _ self valueOfProperty: #url. mine ifNil: [^ self saveIndexOnURL]. Cursor wait showWhile: [strm _ (ServerFile new fullPath: mine)]. strm ifNil: [^ self saveIndexOnURL]. strm class == String ifTrue: [^ self saveIndexOnURL]. strm exists ifFalse: [^ self saveIndexOnURL]. "write whole thing if missing" strm _ strm asStream. strm class == String ifTrue: [^ self saveIndexOnURL]. remote _ strm fileInObjectAndCode. dict _ remote first. allText _ dict at: #allText ifAbsent: [nil]. "remote, not local" allTextUrls _ dict at: #allTextUrls ifAbsent: [nil]. allText size + 1 ~= remote size ifTrue: [self error: '.bo size mismatch. Please tell Ted what you just did to this book.' translated]. (pageURL _ aPage url) ifNil: [self error: 'just had one!!' translated]. fName _ pageURL copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: fName startingAt: 1 caseSensitive: false) > 0 ifTrue: [index _ ii]. "fast" (remote at: ii) xxxReset]. index ifNil: ["new page, what existing page does it follow?" num _ self pageNumberOf: aPage. 1 to: num-1 do: [:ii | (pages at: ii) url ifNotNil: [pre _ (pages at: ii) url]]. pre ifNil: [after _ remote size+1] ifNotNil: ["look for it on disk, put me after" pre _ pre copyAfterLast: $/. 2 to: remote size do: [:ii | ((remote at: ii) url findString: pre startingAt: 1 caseSensitive: false) > 0 ifTrue: [after _ ii+1]]. after ifNil: [after _ remote size+1]]. remote _ remote copyReplaceFrom: after to: after-1 with: #(1). allText ifNotNil: [ dict at: #allText put: (allText copyReplaceFrom: after-1 to: after-2 with: #(())). dict at: #allTextUrls put: (allTextUrls copyReplaceFrom: after-1 to: after-2 with: #(()))]. index _ after]. remote at: index put: (aPage sqkPage copyForSaving). (dict at: #modTime ifAbsent: [0]) < Time totalSeconds ifTrue: [dict at: #modTime put: Time totalSeconds]. allText ifNotNil: [ (dict at: #allText) at: index-1 put: (aPage allStringsAfter: nil). (dict at: #allTextUrls) at: index-1 put: pageURL]. sf _ ServerDirectory new fullPath: mine. Cursor wait showWhile: [ remoteFile _ sf fileNamed: mine. remoteFile fileOutClass: nil andObject: remote. "remoteFile close"]. ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:12'! saveIndexOnURL "Make up an index to the pages of this book, with thumbnails, and store it on the server. (aDictionary, aMorphObjectOut, aMorphObjectOut, aMorphObjectOut). The last part corresponds exactly to what pages looks like when they are all out. Each holds onto a SqueakPage, which holds a url and a thumbnail." | dict list mine sf remoteFile urlList | pages isEmpty ifTrue: [^self]. dict := Dictionary new. dict at: #modTime put: Time totalSeconds. "self getAllText MUST have been called at start of this operation." dict at: #allText put: (self valueOfProperty: #allText). #(#color #borderWidth #borderColor #pageSize) do: [:sel | dict at: sel put: (self perform: sel)]. self reserveUrlsIfNeeded. "should already be done" list := pages copy. "paste dict on front below" "Fix up the entries, should already be done" list doWithIndex: [:out :ind | out isInMemory ifTrue: [(out valueOfProperty: #SqueakPage) ifNil: [out saveOnURLbasic]. list at: ind put: out sqkPage copyForSaving]]. urlList := list collect: [:ppg | ppg url]. self setProperty: #allTextUrls toValue: urlList. dict at: #allTextUrls put: urlList. list := (Array with: dict) , list. mine := self valueOfProperty: #url. mine ifNil: [mine := self getStemUrl , '.bo'. self setProperty: #url toValue: mine]. sf := ServerDirectory new fullPath: mine. Cursor wait showWhile: [remoteFile := sf fileNamed: mine. remoteFile dataIsValid. remoteFile fileOutClass: nil andObject: list "remoteFile close"]! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:18'! saveOnUrlPage: pageMorph "Write out this single page in this book onto a server. See savePagesOnURL. (Don't compute the texts, only this page's is written.)" | stem ind response rand newPlace dir | (self valueOfProperty: #keepTogether) ifNotNil: [ self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. "Don't give the chance to put in a different place. Assume named by number" ((self valueOfProperty: #url) isNil and: [pages first url notNil]) ifTrue: [ response _ (PopUpMenu labels: 'Old book New book sharing old pages' translated) startUpWithCaption: 'Modify the old book, or make a new book sharing its pages?' translated. response = 2 ifTrue: [ "Make up new url for .bo file and confirm with user." "Mark as shared" [rand _ String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace _ self getStemUrl) isEmpty ifTrue: [^ self]. newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir _ ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace]. response = 0 ifTrue: [^ self]]. stem _ self getStemUrl. "user must approve" stem isEmpty ifTrue: [^ self]. ind _ pages identityIndexOf: pageMorph ifAbsent: [self error: 'where is the page?' translated]. pageMorph isInMemory ifTrue: ["not out now" pageMorph saveOnURL: stem,(ind printString),'.sp']. self saveIndexOfOnly: pageMorph.! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 13:20'! savePagesOnURL "Write out all pages in this book onto a server. For any page that does not have a SqueakPage and a url already, ask the user for one. Give the option of naming all page files by page number. Any pages that are not in memory will stay that way. The local disk could be the server." | response list firstTime newPlace rand dir bookUrl | (self valueOfProperty: #keepTogether) ifNotNil: [ self inform: 'This book is marked ''keep in one file''. Several pages use a common Player. Save the owner of the book instead.' translated. ^ self]. self getAllText. "stored with index later" response _ (PopUpMenu labels: 'Use page numbers Type in file names Save in a new place (using page numbers) Save in a new place (typing names) Save new book sharing old pages' translated) startUpWithCaption: 'Each page will be a file on the server. Do you want to page numbers be the names of the files? or name each one yourself?' translated. response = 1 ifTrue: [self saveAsNumberedURLs. ^ self]. response = 3 ifTrue: [self forgetURLs; saveAsNumberedURLs. ^ self]. response = 4 ifTrue: [self forgetURLs]. response = 5 ifTrue: [ "Make up new url for .bo file and confirm with user." "Mark as shared" [rand _ String new: 4. 1 to: rand size do: [:ii | rand at: ii put: ('bdfghklmnpqrstvwz' at: 17 atRandom)]. (newPlace _ self getStemUrl) isEmpty ifTrue: [^ self]. newPlace _ (newPlace copyUpToLast: $/), '/BK', rand, '.bo'. dir _ ServerFile new fullPath: newPlace. (dir includesKey: dir fileName)] whileTrue. "keep doing until a new file" self setProperty: #url toValue: newPlace. self saveAsNumberedURLs. bookUrl _ self valueOfProperty: #url. (SqueakPage stemUrl: bookUrl) = (SqueakPage stemUrl: currentPage url) ifTrue: [ bookUrl _ true]. "not a shared book" (URLMorph grabURL: currentPage url) book: bookUrl. ^ self]. response = 0 ifTrue: [^ self]. "self reserveUrlsIfNeeded. Need two passes here -- name on one, write on second" pages do: [:aPage | "does write the current page too" aPage isInMemory ifTrue: ["not out now" aPage presenter ifNotNil: [aPage presenter flushPlayerListCache]. aPage saveOnURLbasic. ]]. "ask user if no url" list _ pages collect: [:aPage | aPage sqkPage prePurge]. "knows not to purge the current page" list _ (list select: [:each | each notNil]) asArray. "do bulk become:" (list collect: [:each | each contentsMorph]) elementsExchangeIdentityWith: (list collect: [:spg | MorphObjectOut new xxxSetUrl: spg url page: spg]). firstTime _ (self valueOfProperty: #url) isNil. self saveIndexOnURL. self presenter ifNotNil: [self presenter flushPlayerListCache]. firstTime ifTrue: ["Put a thumbnail into the hand" URLMorph grabForBook: self. self setProperty: #futureUrl toValue: nil]. "clean up" ! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 10/26/2003 12:58'! textSearch "search the text on all pages of this book" | wanted wants list str | list _ self valueOfProperty: #searchKey ifAbsent: [#()]. str _ String streamContents: [:strm | list do: [:each | strm nextPutAll: each; space]]. wanted _ FillInTheBlank request: 'words to search for. Order is not important. Beginnings of words are OK.' translated initialAnswer: str. wants _ wanted findTokens: Character separators. wants isEmpty ifTrue: [^ self]. self getAllText. "save in allText, allTextUrls" ^ self findText: wants "goes to the page and highlights the text"! ! !BookMorph methodsFor: 'menu' stamp: 'dgd 2/21/2003 23:14'! textSearch: stringWithKeys "search the text on all pages of this book" | wants | wants := stringWithKeys findTokens: Character separators. wants isEmpty ifTrue: [^self]. self getAllText. "save in allText, allTextUrls" ^self findText: wants "goes to the page and highlights the text"! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 13:31'! goToPage: pageNumber transitionSpec: transitionSpec runTransitionScripts: aBoolean "Go the the given page number; use the transitionSpec supplied, and if the boolean parameter is true, run opening and closing scripts as appropriate" | pageMorph | pages isEmpty ifTrue: [^ self]. pageMorph _ (self hasProperty: #dontWrapAtEnd) ifTrue: [pages atPin: pageNumber] ifFalse: [pages atWrap: pageNumber]. ^ self goToPageMorph: pageMorph transitionSpec: transitionSpec runTransitionScripts: aBoolean! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 21:30'! goToPageMorph: aMorph "Set the given morph as the current page; run closing and opening scripts as appropriate" self goToPageMorph: aMorph runTransitionScripts: true! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 11/8/2002 13:34'! goToPageMorph: aMorph runTransitionScripts: aBoolean "Set the given morph as the current page. If the boolean parameter is true, then opening and closing scripts will be run" self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]) transitionSpec: nil runTransitionScripts: aBoolean ! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/22/2003 18:49'! goToPageMorph: newPage transitionSpec: transitionSpec | pageIndex aWorld oldPageIndex ascending tSpec readIn | pages isEmpty ifTrue: [^self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"]. readIn := newPage isInMemory not. oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil]. ascending := (oldPageIndex isNil or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec := transitionSpec ifNil: ["If transition not specified by requestor..." newPage valueOfProperty: #transitionSpec ifAbsent: [" ... then consult new page" self transitionSpecFor: self " ... otherwise this is the default"]]. self flag: #arNote. "Probably unnecessary" (aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage notNil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^self "In the process of a prior pageTurn"]. self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^(TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete; fullReleaseCachedState. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url. currentPage sqkPage computeThumbnail "just store it"]]]. "No transition, but at least decommission current page" currentPage delete; fullReleaseCachedState]. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrl. currentPage sqkPage computeThumbnail "just store it"]! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/22/2003 18:49'! goToPageMorph: newPage transitionSpec: transitionSpec runTransitionScripts: aBoolean "Install the given page as the new current page; use the given transition spec, and if the boolean parameter is true, run closing and opening scripts on the outgoing and incoming players" | pageIndex aWorld oldPageIndex ascending tSpec readIn | pages isEmpty ifTrue: [^self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex := pages identityIndexOf: newPage ifAbsent: [^self "abort"]. readIn := newPage isInMemory not. oldPageIndex := pages identityIndexOf: currentPage ifAbsent: [nil]. ascending := (oldPageIndex isNil or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec := transitionSpec ifNil: ["If transition not specified by requestor..." newPage valueOfProperty: #transitionSpec ifAbsent: [" ... then consult new page" self transitionSpecFor: self " ... otherwise this is the default"]]. self flag: #arNote. "Probably unnecessary" (aWorld := self world) ifNotNil: [self primaryHand releaseKeyboardFocus]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage notNil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^self "In the process of a prior pageTurn"]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllClosingScripts]]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^(TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete; fullReleaseCachedState. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. aBoolean ifTrue: [self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrlInBook: self url. currentPage sqkPage computeThumbnail "just store it"]]]. "No transition, but at least decommission current page" currentPage delete; fullReleaseCachedState]. self insertPageMorphInCorrectSpot: (pages at: pageIndex). self adjustCurrentPageForFullScreen. self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. self currentPlayerDo: [:aPlayer | aPlayer runAllOpeningScripts]. (aWorld := self world) ifNotNil: ["WHY??" aWorld displayWorld]. readIn ifTrue: [currentPage updateThumbnailUrl. currentPage sqkPage computeThumbnail "just store it"]! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:10'! goToPageUrl: aUrl | pp short | pp := pages detect: [:pg | pg url = aUrl] ifNone: [nil]. pp ifNil: [short := (aUrl findTokens: '/') last. pp := pages detect: [:pg | pg url ifNil: [false] ifNotNil: [(pg url findTokens: '/') last = short] "it moved"] ifNone: [pages first]]. self goToPageMorph: pp! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:11'! nextPage currentPage isNil ifTrue: [^self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) + 1! ! !BookMorph methodsFor: 'navigation' stamp: 'dgd 2/21/2003 23:11'! previousPage currentPage isNil ifTrue: [^self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) - 1! ! !BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 13:55'! adjustCurrentPageForFullScreen "Adjust current page to conform to whether or not I am in full-screen mode. Also, enforce uniform page size constraint if appropriate" self isInFullScreenMode ifTrue: [(currentPage hasProperty: #sizeWhenNotFullScreen) ifFalse: [currentPage setProperty: #sizeWhenNotFullScreen toValue: currentPage extent]. currentPage extent: Display extent] ifFalse: [(currentPage hasProperty: #sizeWhenNotFullScreen) ifTrue: [currentPage extent: (currentPage valueOfProperty: #sizeWhenNotFullScreen). currentPage removeProperty: #sizeWhenNotFullScreen]. self uniformPageSize ifNotNilDo: [:anExtent | currentPage extent: anExtent]]. (self valueOfProperty: #floatingPageControls) ifNotNilDo: [:pc | pc isInWorld ifFalse: [pc openInWorld]]! ! !BookMorph methodsFor: 'other' stamp: 'tk 2/19/2001 18:35'! makeMinimalControlsWithColor: aColor title: aString | aButton aColumn aRow but | aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0. aColumn _ AlignmentMorph newColumn. aColumn color: aButton color; borderWidth: 0; layoutInset: 0. aColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow _ AlignmentMorph newRow. aRow color: aButton color; borderWidth: 0; layoutInset: 0. aRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. aRow addTransparentSpacerOfSize: 40@0. aRow addMorphBack: (but _ aButton label: ' < ' ; actionSelector: #previousPage). "copy is OK, since we just made it and it can't own any Players" but setBalloonText: 'Go to previous page'. aRow addTransparentSpacerOfSize: 82@0. aRow addMorphBack: (StringMorph contents: aString) lock. aRow addTransparentSpacerOfSize: 82@0. aButton _ SimpleButtonMorph new target: self; borderColor: Color black; color: aColor; borderWidth: 0. aRow addMorphBack: (but _ aButton label: ' > ' ; actionSelector: #nextPage). but setBalloonText: 'Go to next page'. aRow addTransparentSpacerOfSize: 40@0. aColumn addMorphBack: aRow. aColumn setNameTo: 'Page Controls'. ^ aColumn! ! !BookMorph methodsFor: 'other' stamp: 'sw 6/6/2003 17:21'! setExtentFromHalo: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed. For a BookMorph, we assume any resizing attempt is a request that the book-page currently being viewed be resized accoringly; this will typically not affect unseen book pages, though there is a command that can be issued to harmonize all book-page sizes, and also an option to set that will maintain all pages at the same size no matter what." currentPage isInWorld ifFalse: "doubtful case mostly" [super setExtentFromHalo: anExtent] ifTrue: [currentPage width: anExtent x. currentPage height: (anExtent y - (self innerBounds height - currentPage height)). self maintainsUniformPageSize ifTrue: [self setProperty: #uniformPageSize toValue: currentPage extent]]! ! !BookMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:52'! initializeToStandAlone self initialize. self removeEverything; pageSize: 360@228; color: (Color gray: 0.9). self borderWidth: 1; borderColor: Color black. self beSticky. self showPageControls; insertPage. ^ self! ! !BookMorph methodsFor: 'sorting' stamp: 'dgd 2/21/2003 23:09'! acceptSortedContentsFrom: aHolder "Update my page list from the given page sorter." | goodPages rejects toAdd sqPage | goodPages := OrderedCollection new. rejects := OrderedCollection new. aHolder submorphs doWithIndex: [:m :i | toAdd := nil. (m isKindOf: PasteUpMorph) ifTrue: [toAdd := m]. (m isKindOf: BookPageThumbnailMorph) ifTrue: [toAdd := m page. m bookMorph == self ifFalse: ["borrowed from another book. preserve the original" toAdd := toAdd veryDeepCopy. "since we came from elsewhere, cached strings are wrong" self removeProperty: #allTextUrls. self removeProperty: #allText]]. toAdd class == String ifTrue: ["a url" toAdd := pages detect: [:aPage | aPage url = toAdd] ifNone: [toAdd]]. toAdd class == String ifTrue: [sqPage := SqueakPageCache atURL: toAdd. toAdd := sqPage contentsMorph ifNil: [sqPage copyForSaving "a MorphObjectOut"] ifNotNil: [sqPage contentsMorph]]. toAdd ifNil: [rejects add: m] ifNotNil: [goodPages add: toAdd]]. self newPages: goodPages. goodPages isEmpty ifTrue: [self insertPage]. rejects notEmpty ifTrue: [self inform: rejects size printString , ' objects vanished in this process.']! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 3/3/2004 18:39'! keepingUniformPageSizeString "Answer a string characterizing whether I am currently maintaining uniform page size" ^ (self maintainsUniformPageSize ifTrue: [''] ifFalse: ['']), 'keep all pages the same size' translated! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'! maintainsUniformPageSize "Answer whether I am currently set up to maintain uniform page size" ^ self uniformPageSize notNil! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:56'! maintainsUniformPageSize: aBoolean "Set the property governing whether I maintain uniform page size" aBoolean ifFalse: [self removeProperty: #uniformPageSize] ifTrue: [self setProperty: #uniformPageSize toValue: currentPage extent]! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'! toggleMaintainUniformPageSize "Toggle whether or not the receiver should maintain uniform page size" self maintainsUniformPageSize: self maintainsUniformPageSize not! ! !BookMorph methodsFor: 'uniform page size' stamp: 'sw 6/6/2003 13:57'! uniformPageSize "Answer the uniform page size to maintain, or nil if the option is not set" ^ self valueOfProperty: #uniformPageSize ifAbsent: [nil]! ! !BookMorph methodsFor: 'menus' stamp: 'yo 7/2/2004 13:05'! printPSToFile "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag | fileName _ ('MyBook') translated asFileName. fileName _ FillInTheBlank request: 'File name? (".ps" will be added to end)' translated initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: '.ps') ifFalse: [fileName _ fileName,'.ps']. rotateFlag _ ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. (FileStream newFileNamed: fileName asFileName) nextPutAll: (DSCPostscriptCanvas morphAsPostscript: self rotated: rotateFlag); close. ! ! !BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:31'! initialize FileList registerFileReader: self. self registerInFlapsRegistry. ! ! !BookMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:37'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') forFlapNamed: 'Supplies'. cl registerQuad: #(BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') forFlapNamed: 'Supplies'. cl registerQuad: #(BookMorph authoringPrototype 'Book' 'A multi-paged structure') forFlapNamed: 'Supplies']! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:28'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'bo') | (suffix = '*') ifTrue: [ Array with: self serviceLoadAsBook] ifFalse: [#()] ! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'LEG 10/25/2001 00:06'! openFromFile: fullName "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world" | book aFileStream | Smalltalk verifyMorphicAvailability ifFalse: [^ self]. aFileStream _ FileStream oldFileNamed: fullName. book _ BookMorph new. book setProperty: #url toValue: aFileStream url. book fromRemoteStream: aFileStream. aFileStream close. Smalltalk isMorphic ifTrue: [ActiveWorld addMorphsAndModel: book] ifFalse: [book isMorph ifFalse: [^self inform: 'Can only load a single morph into an mvc project via this mechanism.']. book openInWorld]. book goToPage: 1! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'! serviceLoadAsBook ^ SimpleServiceEntry provider: self label: 'load as book' selector: #openFromFile: description: 'open as bookmorph'! ! !BookMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:33'! services ^ Array with: self serviceLoadAsBook! ! !BookMorph class methodsFor: 'initialize-release' stamp: 'asm 4/11/2003 12:31'! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]! ! !BookMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:20'! descriptionForPartsBin ^ self partName: 'Book' categories: #('Presentation') documentation: 'Multi-page structures'! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 11/7/2002 13:20'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((#'book navigation' ((command goto: 'go to the given page' Player) (command nextPage 'go to next page') (command previousPage 'go to previous page') (command firstPage 'go to first page') (command lastPage 'go to last page') (slot pageNumber 'The ordinal number of the current page' Number readWrite Player getPageNumber Player setPageNumber:))))! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 17:14'! nextPageButton "Answer a button that will take the user to the next page of its enclosing book" | aButton | aButton _ SimpleButtonMorph new. aButton target: aButton; actionSelector: #nextOwnerPage; label: '->'; color: Color yellow. aButton setNameTo: 'next'. ^ aButton! ! !BookMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 17:13'! previousPageButton "Answer a button that will take the user to the previous page of its enclosing book" | aButton | aButton _ SimpleButtonMorph new. aButton target: aButton; actionSelector: #previousOwnerPage; color: Color yellow; label: '<-'. aButton setNameTo: 'previous'. ^ aButton! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:21'! addControls | bb r aButton str | r _ AlignmentMorph newRow color: Color transparent; borderWidth: 0; layoutInset: 0. r wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Okay' translated; actionSelector: #acceptSort)). bb _ SimpleButtonMorph new target: self; borderColor: Color black. r addMorphBack: (self wrapperFor: (bb label: 'Cancel' translated; actionSelector: #delete)). r addTransparentSpacerOfSize: 8 @ 0. r addMorphBack: (self wrapperFor: (aButton _ UpdatingThreePhaseButtonMorph checkBox)). aButton target: self; actionSelector: #togglePartsBinStatus; arguments: #(); getSelector: #getPartsBinStatus. str _ StringMorph contents: 'Parts bin' translated. r addMorphBack: (self wrapperFor: str lock). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/17/2003 19:56'! changeExtent: aPoint self extent: aPoint. pageHolder extent: self extent - self borderWidth! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/26/2003 13:22'! closeButtonOnly "Replace my default control panel with one that has only a close button." | b r | self firstSubmorph delete. "remove old control panel" b _ SimpleButtonMorph new target: self; borderColor: Color black. r _ AlignmentMorph newRow. r color: b color; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r wrapCentering: #topLeft. r addMorphBack: (b label: 'Close' translated; actionSelector: #delete). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:55'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:55'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !BookPageSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:56'! initialize "initialize the state of the receiver" super initialize. "" self extent: Display extent - 100; listDirection: #topToBottom; wrapCentering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 3. pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent -self borderWidth. pageHolder hResizing: #shrinkWrap. "pageHolder cursor: 0." "causes a walkback as of 5/25/2000" self addControls. self addMorphBack: pageHolder! ! !BookPageThumbnailMorph methodsFor: 'event handling' stamp: 'tk 7/25/2001 18:09'! mouseDown: event "turn the book to that page" "May need to lie to it so mouseUp won't go to menu that may come up during fetch of a page in doPageFlip. (Is this really true? --tk)" self doPageFlip. ! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 10/26/2003 13:23'! objectForDataStream: refStrm "I am about to be written on an object file. It would be bad to write a whole BookMorph out. Store a string that is the url of the book or page in my inst var." | clone bookUrl bb stem ind | (bookMorph class == String) & (page class == String) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page class == String) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page url notNil) ifTrue: [ ^ super objectForDataStream: refStrm]. (bookMorph isNil) & (page url isNil) ifTrue: [ self error: 'page should already have a url' translated. "find page's book, and remember it" "bookMorph _ "]. clone _ self clone. (bookUrl _ bookMorph url) ifNil: [bookUrl _ self valueOfProperty: #futureUrl]. bookUrl ifNil: [ bb _ RectangleMorph new. "write out a dummy" bb bounds: bounds. refStrm replace: self with: bb. ^ bb] ifNotNil: [clone instVarNamed: 'bookMorph' put: bookUrl]. page url ifNil: [ "Need to assign a url to a page that will be written later. It might have bookmarks too. Don't want to recurse deeply. Have that page write out a dummy morph to save its url on the server." stem _ SqueakPage stemUrl: bookUrl. ind _ bookMorph pages identityIndexOf: page. page reserveUrl: stem,(ind printString),'.sp']. clone instVarNamed: 'page' put: page url. refStrm replace: self with: clone. ^ clone! ! !BookPageThumbnailMorph methodsFor: 'fileIn/Out' stamp: 'dgd 10/26/2003 13:23'! objectsInMemory "See if page or bookMorph need to be brought in from a server." | bookUrl bk wld try | bookMorph ifNil: ["fetch the page" page class == String ifFalse: [^ self]. "a morph" try _ (SqueakPageCache atURL: page) fetchContents. try ifNotNil: [page _ try]. ^ self]. bookMorph class == String ifTrue: [ bookUrl _ bookMorph. (wld _ self world) ifNil: [wld _ Smalltalk currentWorld]. bk _ BookMorph isInWorld: wld withUrl: bookUrl. bk == #conflict ifTrue: [ ^ self inform: 'This book is already open in some other project' translated]. bk == #out ifTrue: [ (bk _ BookMorph new fromURL: bookUrl) ifNil: [^ self]]. bookMorph _ bk]. page class == String ifTrue: [ page _ (bookMorph pages detect: [:pg | pg url = page] ifNone: [bookMorph pages first])]. ! ! !BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !BookPageThumbnailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:53'! initialize "initialize the state of the receiver" | f | super initialize. "" flipOnClick _ false. f _ Form extent: 60 @ 80 depth: Display depth. f fill: f boundingBox fillColor: color. self form: f! ! !BookPageThumbnailMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:57'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'make a flex morph' translated selector: #makeFlexMorphFor: argument: aHandMorph. flipOnClick ifTrue: [aCustomMenu add: 'disable bookmark action' translated action: #toggleBookmark] ifFalse: [aCustomMenu add: 'enable bookmark action' translated action: #toggleBookmark]. (bookMorph isKindOf: BookMorph) ifTrue: [aCustomMenu add: 'set page sound' translated action: #setPageSound:. aCustomMenu add: 'set page visual' translated action: #setPageVisual:] ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 21:13'! addBookMenuItemsTo: aCustomMenu hand: aHandMorph (self hasSubmorphWithProperty: #pageControl) ifTrue: [aCustomMenu add: 'hide page controls' translated action: #hidePageControls] ifFalse: [aCustomMenu add: 'show page controls' translated action: #showPageControls]! ! !BooklikeMorph methodsFor: 'misc' stamp: 'gk 2/24/2004 08:27'! playPageFlipSound: soundName self presenter ifNil: [^ self]. "Avoid failures when called too early" PageFlipSoundOn "mechanism to suppress sounds at init time" ifTrue: [self playSoundNamed: soundName]. ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04'! showingFullScreenString ^ (self isInFullScreenMode ifTrue: ['exit full screen'] ifFalse: ['show full screen']) translated! ! !BooklikeMorph methodsFor: 'misc' stamp: 'dgd 9/19/2003 11:04'! showingPageControlsString ^ (self pageControlsVisible ifTrue: ['hide page controls'] ifFalse: ['show page controls']) translated! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 14:10'! addPageControlMorph: aMorph "Add the morph provided as a page control, at the appropriate place" aMorph setProperty: #pageControl toValue: true. self addMorph: aMorph asElementNumber: self indexForPageControls! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'yo 1/14/2005 19:25'! fullControlSpecs ^ { #spacer. #variableSpacer. {'-'. #deletePage. 'Delete this page' translated}. #spacer. {'«'. #firstPage. 'First page' translated}. #spacer. {'<'. #previousPage. 'Previous page' translated}. #spacer. {'·'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}. #spacer. {'>'. #nextPage. 'Next page' translated}. #spacer. { '»'. #lastPage. 'Final page' translated}. #spacer. {'+'. #insertPage. 'Add a new page after this one' translated}. #variableSpacer. {'³'. #fewerPageControls. 'Fewer controls' translated} } ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 17:00'! indexForPageControls "Answer which submorph should hold the page controls" ^ (submorphs size > 0 and: [submorphs first hasProperty: #header]) ifTrue: [2] ifFalse: [1]! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'tk 2/19/2001 18:34'! makePageControlsFrom: controlSpecs "From the controlSpecs, create a set of page control and return them -- this method does *not* add the controls to the receiver." | c col row b lastGuy | c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker]. col _ AlignmentMorph newColumn. col color: c; borderWidth: 0; layoutInset: 0. col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. row _ AlignmentMorph newRow. row color: c; borderWidth: 0; layoutInset: 0. row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. controlSpecs do: [:spec | spec == #spacer ifTrue: [row addTransparentSpacerOfSize: (10 @ 0)] ifFalse: [spec == #variableSpacer ifTrue: [row addMorphBack: AlignmentMorph newVariableTransparentSpacer] ifFalse: [b _ SimpleButtonMorph new target: self; borderWidth: 1; borderColor: Color veryLightGray; color: c. b label: spec first; actionSelector: spec second; borderWidth: 0; setBalloonText: spec third. row addMorphBack: b. (((lastGuy _ spec last asLowercase) includesSubString: 'menu') or: [lastGuy includesSubString: 'designations']) ifTrue: [b actWhen: #buttonDown]]]]. "pop up menu on mouseDown" col addMorphBack: row. ^ col! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 22:44'! setEventHandlerForPageControls: controls "Set the controls' event handler if appropriate. Default is to let the tool be dragged by the controls" controls eventHandler: (EventHandler new on: #mouseDown send: #move to: self)! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'dgd 9/19/2003 11:35'! shortControlSpecs ^ { #spacer. #variableSpacer. {'<'. #previousPage. 'Previous page' translated}. #spacer. {'·'. #invokeBookMenu. 'Click here to get a menu of options for this book.' translated}. #spacer. {'>'. #nextPage. 'Next page' translated}. #spacer. #variableSpacer. {'³'. #showMoreControls. 'More controls' translated} } ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 6/6/2003 13:58'! showPageControls: controlSpecs "Remove any existing page controls, and add fresh controls at the top of the receiver (or in position 2 if the receiver's first submorph is one with property #header). Add a single column of controls." | pageControls column | self hidePageControls. column _ AlignmentMorph newColumn beTransparent. pageControls _ self makePageControlsFrom: controlSpecs. pageControls borderWidth: 0; layoutInset: 4. pageControls beSticky. pageControls setNameTo: 'Page Controls'. self setEventHandlerForPageControls: pageControls. column addMorphBack: pageControls. self addPageControlMorph: column! ! !Boolean methodsFor: 'logical operations' stamp: 'PH 10/3/2003 08:10'! ==> aBlock "this is material implication, a ==> b, also known as: b if a a implies b if a then b b is a consequence of a a therefore b (but note: 'it is raining therefore it is cloudy' is implication; 'it is autumn therefore the leaves are falling' is equivalence). Here is the truth table for material implication (view in a monospaced font): p | q | p ==> q -------|-------|------------- T | T | T T | F | F F | T | T F | F | T " ^self not or: [aBlock value]! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 and: block3 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:44'! and: block1 and: block2 and: block3 and: block4 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self ifFalse: [^ false]. block1 value ifFalse: [^ false]. block2 value ifFalse: [^ false]. block3 value ifFalse: [^ false]. block4 value ifFalse: [^ false]. ^ true! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 or: block3 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'controlling' stamp: 'zz 3/2/2004 23:45'! or: block1 or: block2 or: block3 or: block4 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self ifTrue: [^ true]. block1 value ifTrue: [^ true]. block2 value ifTrue: [^ true]. block3 value ifTrue: [^ true]. block4 value ifTrue: [^ true]. ^ false! ! !Boolean methodsFor: 'printing' stamp: 'sw 9/27/2001 17:19'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Boolean! ! !BooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:36'! offerPreferenceNameMenu: aPanel with: ignored1 in: ignored2 "the user clicked on a preference name -- put up a menu" | aMenu | ActiveHand showTemporaryCursor: nil. aMenu := MenuMorph new defaultTarget: self preference. aMenu addTitle: self preference name. (Preferences okayToChangeProjectLocalnessOf: self preference name) ifTrue: [aMenu addUpdating: #isProjectLocalString target: self preference action: #toggleProjectLocalness. aMenu balloonTextForLastItem: 'Some preferences are best applied uniformly to all projects, and others are best set by each individual project. If this item is checked, then this preference will be printed in bold and will have a separate value for each project']. aMenu add: 'browse senders' target: self systemNavigation selector: #browseAllCallsOn: argument: self preference name. aMenu balloonTextForLastItem: 'This will open a method-list browser on all methods that the send the preference "', self preference name, '".'. aMenu add: 'show category...' target: aPanel selector: #findCategoryFromPreference: argument: self preference name. aMenu balloonTextForLastItem: 'Allows you to find out which category, or categories, this preference belongs to.'. Smalltalk isMorphic ifTrue: [aMenu add: 'hand me a button for this preference' target: self selector: #tearOffButton. aMenu balloonTextForLastItem: 'Will give you a button that governs this preference, which you may deposit wherever you wish']. aMenu add: 'copy this name to clipboard' target: self preference selector: #copyName. aMenu balloonTextForLastItem: 'Copy the name of the preference to the text clipboard, so that you can paste into code somewhere'. aMenu popUpInWorld! ! !BooleanPreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:33'! representativeButtonWithColor: aColor inPanel: aPreferencesPanel "Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place" | outerButton aButton str miniWrapper | outerButton := AlignmentMorph newRow height: 24. outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]). outerButton hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]). outerButton vResizing: #shrinkWrap. outerButton addMorph: (aButton := UpdatingThreePhaseButtonMorph checkBox). aButton target: self preference; actionSelector: #togglePreferenceValue; getSelector: #preferenceValue. outerButton addTransparentSpacerOfSize: (2 @ 0). str := StringMorph contents: self preference name font: (StrikeFont familyName: 'NewYork' size: 12). self preference localToProject ifTrue: [str emphasis: 1]. miniWrapper := AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. miniWrapper beTransparent addMorphBack: str lock. aPreferencesPanel ifNotNil: "We're in a Preferences panel" [miniWrapper on: #mouseDown send: #offerPreferenceNameMenu:with:in: to: self withValue: aPreferencesPanel. miniWrapper on: #mouseEnter send: #menuButtonMouseEnter: to: miniWrapper. miniWrapper on: #mouseLeave send: #menuButtonMouseLeave: to: miniWrapper. miniWrapper setBalloonText: 'Click here for a menu of options regarding this preference. Click on the checkbox to the left to toggle the setting of this preference'] ifNil: "We're a naked button, not in a panel" [miniWrapper setBalloonText: self preference helpString; setProperty: #balloonTarget toValue: aButton]. outerButton addMorphBack: miniWrapper. outerButton setNameTo: self preference name. aButton setBalloonText: self preference helpString. ^ outerButton "(Preferences preferenceAt: #balloonHelpEnabled) view tearOffButton"! ! !BooleanPreferenceView commentStamp: '' prior: 0! I am responsible for building the visual representation of a preference that accepts true and false values! !BooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:55'! initialize PreferenceViewRegistry ofBooleanPreferences register: self.! ! !BooleanPreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:55'! unload PreferenceViewRegistry ofBooleanPreferences unregister: self.! ! !BooleanPreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:10'! handlesPanel: aPreferencePanel ^aPreferencePanel isKindOf: PreferencesPanel! ! !BooleanScriptEditor methodsFor: 'dropping/grabbing' stamp: 'sw 3/15/2005 22:43'! wantsDroppedMorph: aMorph event: evt "Answer whether the receiver would be interested in accepting the morph" (submorphs detect: [:m | m isAlignmentMorph] ifNone: [nil]) ifNotNil: [^ false]. ((aMorph isKindOf: ParameterTile) and: [aMorph scriptEditor == self topEditor]) ifTrue: [^ true]. ^ (aMorph isKindOf: PhraseTileMorph orOf: WatcherWrapper) and: [(#(#Command #Unknown) includes: aMorph resultType capitalized) not]! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'tk 3/1/2001 11:24'! hibernate "do nothing"! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'dgd 2/22/2003 14:44'! storeCodeOn: aStream indent: tabCount (submorphs notEmpty and: [submorphs first submorphs notEmpty]) ifTrue: [aStream nextPutAll: '(('. super storeCodeOn: aStream indent: tabCount. aStream nextPutAll: ') ~~ false)'. ^self]. aStream nextPutAll: ' true '! ! !BooleanScriptEditor methodsFor: 'other' stamp: 'tk 2/28/2001 21:07'! unhibernate "do nothing"! ! !BooleanTest methodsFor: 'testing-printing' stamp: 'md 3/5/2003 00:43'! testBasicType self should: [true basicType = #Boolean]. self should: [false basicType = #Boolean].! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:29'! testBooleanInitializedInstance self should:[Boolean initializedInstance = nil].! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:52'! testBooleanNew self should: [Boolean new] raise: TestResult error. self should: [True new] raise: TestResult error. self should: [False new] raise: TestResult error. ! ! !BooleanTest methodsFor: 'testing' stamp: 'md 3/25/2003 23:09'! testNew self should: [Boolean new] raise: TestResult error. ! ! !BooleanTest methodsFor: 'testing-misc' stamp: 'md 3/6/2003 15:22'! testNewTileMorphRepresentative self should: [false newTileMorphRepresentative isKindOf: TileMorph]. self should: [false newTileMorphRepresentative literal = false]. self should: [true newTileMorphRepresentative literal = true].! ! !BooleanTest commentStamp: '' prior: 0! This is the unit test for the class Boolean. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category ! !BooleanTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:19'! resultType "Answer the result type of the receiver" ^ #Boolean! ! !BooleanType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:20'! defaultArgumentTile "Answer a tile to represent the type" ^ true newTileMorphRepresentative typeColor: self typeColor! ! !BooleanType methodsFor: 'tiles' stamp: 'yo 2/18/2005 16:39'! setFormatForDisplayer: aDisplayer "Set up the displayer to have the right format characteristics" aDisplayer useSymbolFormat. aDisplayer growable: true ! ! !BooleanType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:20'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ true! ! !BooleanType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Boolean! ! !BooleanType methodsFor: 'color' stamp: 'sw 9/27/2001 17:20'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.94 1.0 0.06)! ! !BooleanType commentStamp: 'sw 1/5/2005 22:15' prior: 0! A data type representing Boolean values, i.e., true or false.! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:22'! colorsAtCorners ^Array new: 4 withAll: self color! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! dotOfSize: diameter forDirection: aDirection | form | form _ Form extent: diameter@diameter depth: Display depth. form getCanvas fillOval: form boundingBox color: self color. ^form! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#none! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width ^0! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width: aNumber "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! widthForRounding ^self width! ! !BorderStyle methodsFor: 'color tracking' stamp: 'ar 8/25/2001 17:29'! trackColorFrom: aMorph "If necessary, update our color to reflect a change in aMorphs color"! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 18:38'! = aBorderStyle ^self species = aBorderStyle species and:[self style == aBorderStyle style and:[self width = aBorderStyle width and:[self color = aBorderStyle color]]].! ! !BorderStyle methodsFor: 'comparing' stamp: 'ar 8/25/2001 16:08'! hash "hash is implemented because #= is implemented" ^self species hash bitXor: (self width hash bitXor: self color hash)! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:01'! drawLineFrom: startPoint to: stopPoint on: aCanvas ^aCanvas line: startPoint to: stopPoint width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameOval: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameOval: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:57'! framePolygon: vertices on: aCanvas "Frame the given rectangle on aCanvas" self framePolyline: vertices on: aCanvas. self drawLineFrom: vertices last to: vertices first on: aCanvas.! ! !BorderStyle methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:59'! framePolyline: vertices on: aCanvas "Frame the given rectangle on aCanvas" | prev next | prev := vertices first. 2 to: vertices size do: [:i | next := vertices at: i. self drawLineFrom: prev to: next on: aCanvas. prev := next]! ! !BorderStyle methodsFor: 'drawing' stamp: 'ar 8/25/2001 16:24'! frameRectangle: aRectangle on: aCanvas "Frame the given rectangle on aCanvas" aCanvas frameRectangle: aRectangle width: self width color: self color! ! !BorderStyle methodsFor: 'initialize' stamp: 'ar 8/25/2001 16:06'! releaseCachedState "Release any associated cached state"! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! isBorderStyle ^true! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^false! ! !BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0! See BorderedMorph BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/26/2001 16:05'! borderStyleChoices "Answer the superset of all supported borderStyle symbols" ^ #(simple inset raised complexAltFramed complexAltInset complexAltRaised complexFramed complexInset complexRaised)! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'yo 7/2/2004 17:21'! borderStyleForSymbol: sym "Answer a border style corresponding to the given symbol" | aSymbol | aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym]. ^ self perform: aSymbol " | aSymbol selector | aSymbol _ sym == #none ifTrue: [#simple] ifFalse: [sym]. selector _ Vocabulary eToyVocabulary translationKeyFor: aSymbol. selector isNil ifTrue: [selector _ aSymbol]. ^ self perform: selector " ! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 23:52'! color: aColor width: aNumber ^self width: aNumber color: aColor! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltFramed ^ComplexBorder style: #complexAltFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:01'! complexAltInset ^ComplexBorder style: #complexAltInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexAltRaised ^ComplexBorder style: #complexAltRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexFramed ^ComplexBorder style: #complexFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexInset ^ComplexBorder style: #complexInset! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexRaised ^ComplexBorder style: #complexRaised! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 17:26'! default ^Default ifNil:[Default _ self new]! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! inset ^InsetBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 14:59'! raised ^RaisedBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'sw 11/27/2001 15:22'! simple "Answer a simple border style" ^ SimpleBorder new! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber ^self width: aNumber color: Color black! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:19'! width: aNumber color: aColor ^SimpleBorder new color: aColor; width: aNumber; yourself! ! !BorderedMorph methodsFor: 'accessing' stamp: 'ar 8/17/2001 16:52'! borderColor: colorOrSymbolOrNil self doesBevels ifFalse:[ colorOrSymbolOrNil isColor ifFalse:[^self]]. borderColor = colorOrSymbolOrNil ifFalse: [ borderColor _ colorOrSymbolOrNil. self changed]. ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:19'! borderStyle "Work around the borderWidth/borderColor pair" | style | borderColor ifNil: [^BorderStyle default]. borderWidth isZero ifTrue: [^BorderStyle default]. style := self valueOfProperty: #borderStyle ifAbsent: [BorderStyle default]. (borderWidth = style width and: ["Hah!! Try understanding this..." borderColor == style style or: ["#raised/#inset etc" #simple == style style and: [borderColor = style color]]]) ifFalse: [style := borderColor isColor ifTrue: [BorderStyle width: borderWidth color: borderColor] ifFalse: [(BorderStyle perform: borderColor) width: borderWidth "argh."]. self setProperty: #borderStyle toValue: style]. ^style trackColorFrom: self! ! !BorderedMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 22:42'! borderStyle: aBorderStyle "Work around the borderWidth/borderColor pair" aBorderStyle = self borderStyle ifTrue: [^self]. "secure against invalid border styles" (self canDrawBorder: aBorderStyle) ifFalse: ["Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: aBorderStyle width color: (aBorderStyle trackColorFrom: self) color)]. aBorderStyle width = self borderStyle width ifFalse: [self changed]. (aBorderStyle isNil or: [aBorderStyle == BorderStyle default]) ifTrue: [self removeProperty: #borderStyle. borderWidth := 0. ^self changed]. self setProperty: #borderStyle toValue: aBorderStyle. borderWidth := aBorderStyle width. borderColor := aBorderStyle style == #simple ifTrue: [aBorderStyle color] ifFalse: [aBorderStyle style]. self changed! ! !BorderedMorph methodsFor: 'drawing' stamp: 'dgd 2/17/2003 19:57'! areasRemainingToFill: aRectangle (color isColor and: [color isTranslucent]) ifTrue: [^ Array with: aRectangle]. self wantsRoundedCorners ifTrue: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] ifFalse: [(self borderWidth > 0 and: [self borderColor isColor and: [self borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: self innerBounds] ifFalse: [^ aRectangle areasOutside: self bounds]]! ! !BorderedMorph methodsFor: 'geometry' stamp: 'sw 5/18/2001 22:52'! acquireBorderWidth: aBorderWidth "Gracefully acquire the new border width, keeping the interior area intact and not seeming to shift" | delta | (delta _ aBorderWidth- self borderWidth) == 0 ifTrue: [^ self]. self bounds: ((self bounds origin - (delta @ delta)) corner: (self bounds corner + (delta @ delta))). self borderWidth: aBorderWidth. self layoutChanged! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00'! basicInitialize "Do basic generic initialization of the instance variables" super basicInitialize. "" self borderInitialize! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:53'! borderInitialize "initialize the receiver state related to border" borderColor_ self defaultBorderColor. borderWidth _ self defaultBorderWidth! ]style[(16 2 49 15 4 22 11 3 4 19)f2b,f2,f2c147045000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:07'! initialize "initialize the state of the receiver" super initialize. "" self borderInitialize! ! !BorderedMorph methodsFor: 'menu' stamp: 'yo 7/31/2004 17:41'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu addTitle: 'border' translated. subMenu addStayUpItemSpecial. subMenu addList: {{'border color...' translated. #changeBorderColor:}. {'border width...' translated. #changeBorderWidth:}}. subMenu addLine. BorderStyle borderStyleChoices do: [:sym | (self borderStyleForSymbol: sym) ifNotNil: [subMenu add: sym translated target: self selector: #setBorderStyle: argument: sym]]. aMenu add: 'border style...' translated subMenu: subMenu ! ! !BorderedMorph methodsFor: 'menu' stamp: 'md 12/12/2003 16:21'! changeBorderWidth: evt | handle origin aHand newWidth oldWidth | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand position. oldWidth _ borderWidth. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). newWidth _ (newPoint - origin) r asInteger // 5. self borderWidth: newWidth] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNilDo: [:halo | halo addHandles]. self rememberCommand: (Command new cmdWording: 'border change' translated; undoTarget: self selector: #borderWidth: argument: oldWidth; redoTarget: self selector: #borderWidth: argument: newWidth)]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase border width. Click when done.' hand: evt hand. handle startStepping! ! !BorderedMorph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/4/2004 11:47'! understandsBorderVocabulary "Replace the 'isKindOf: BorderedMorph' so that (for instance) Connectors can have their border vocabulary visible in viewers." ^true! ! !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0! BorderedMorph introduce borders to morph. Borders have the instanceVariables borderWidth and borderColor. BorderedMorph new borderColor: Color red; borderWidth: 10; openInWorld. BorderedMorph also have a varaity of border styles: simple, inset, raised, complexAltFramed, complexAltInset, complexAltRaised, complexFramed, complexInset, complexRaised. These styles are set using the classes BorderStyle, SimpleBorder, RaisedBorder, InsetBorder and ComplexBorder. BorderedMorph new borderStyle: (SimpleBorder width: 1 color: Color white); openInWorld. BorderedMorph new borderStyle: (BorderStyle inset width: 2); openInWorld. ! !BorderedStringMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 03:03'! measureContents ^super measureContents +2.! ! !BorderedStringMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:34'! drawOn: aCanvas | nameForm | font _ self fontToUse. nameForm _ Form extent: bounds extent depth: 8. nameForm getCanvas drawString: contents at: 0@0 font: self fontToUse color: Color black. (bounds origin + 1) eightNeighbors do: [ :pt | aCanvas stencil: nameForm at: pt color: self borderColor. ]. aCanvas stencil: nameForm at: bounds origin + 1 color: color. ! ! !BorderedStringMorph methodsFor: 'initialization' stamp: 'ar 12/14/2001 20:02'! initWithContents: aString font: aFont emphasis: emphasisCode super initWithContents: aString font: aFont emphasis: emphasisCode. self borderStyle: (SimpleBorder width: 1 color: Color white).! ! !BorderedStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" self borderStyle: (SimpleBorder width: 1 color: Color white)! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! firstEnter: evt "The first time this divider is activated, find its window and redirect further interaction there." | window | window := self firstOwnerSuchThat: [:m | m respondsTo: #secondaryPaneTransition:divider:]. window ifNil: [ self suspendEventHandler. ^ self ]. "not working out" window secondaryPaneTransition: evt divider: self. self on: #mouseEnter send: #secondaryPaneTransition:divider: to: window. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! horizontal self hResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge ^resizingEdge ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! resizingEdge: edgeSymbol (#(top bottom) includes: edgeSymbol) ifFalse: [ self error: 'resizingEdge must be #top or #bottom' ]. resizingEdge := edgeSymbol. self on: #mouseEnter send: #firstEnter: to: self. ! ! !BorderedSubpaneDividerMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! vertical self vResizing: #spaceFill.! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !BorderedSubpaneDividerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:09'! initialize "initialize the state of the receiver" super initialize. "" self extent: 1 @ 1! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:24'! forBottomEdge ^self new horizontal resizingEdge: #bottom! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! forTopEdge ^self new horizontal resizingEdge: #top! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! horizontal ^self new horizontal! ! !BorderedSubpaneDividerMorph class methodsFor: 'as yet unclassified' stamp: 'ar 8/15/2001 23:25'! vertical ^self new vertical! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.8! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:14'! initialize "initialize the state of the receiver" super initialize. "" damageReported _ false. self extent: 400 @ 250. infectionHistory _ OrderedCollection new. transmitInfection _ false. self addAtoms: 30! ! !BouncingAtomsMorph methodsFor: 'initialization' stamp: 'ar 8/13/2003 11:41'! intoWorld: aWorld "Make sure report damage at least once" damageReported _ false. super intoWorld: aWorld.! ! !BouncingAtomsMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:15'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'startInfection' translated action: #startInfection. aCustomMenu add: 'set atom count' translated action: #setAtomCount. aCustomMenu add: 'show infection history' translated action: #showInfectionHistory:. ! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'aoy 2/15/2003 21:38'! collisionPairs "Return a list of pairs of colliding atoms, which are assumed to be circles of known radius. This version uses the morph's positions--i.e. the top-left of their bounds rectangles--rather than their centers." | count sortedAtoms radius twoRadii radiiSquared collisions p1 continue j p2 distSquared m1 m2 | count := submorphs size. sortedAtoms := submorphs asSortedCollection: [:mt1 :mt2 | mt1 position x < mt2 position x]. radius := 8. twoRadii := 2 * radius. radiiSquared := radius squared * 2. collisions := OrderedCollection new. 1 to: count - 1 do: [:i | m1 := sortedAtoms at: i. p1 := m1 position. continue := (j := i + 1) <= count. [continue] whileTrue: [m2 := sortedAtoms at: j. p2 := m2 position. continue := p2 x - p1 x <= twoRadii ifTrue: [distSquared := (p1 x - p2 x) squared + (p1 y - p2 y) squared. distSquared < radiiSquared ifTrue: [collisions add: (Array with: m1 with: m2)]. (j := j + 1) <= count] ifFalse: [false]]]. ^collisions! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'dgd 2/22/2003 13:36'! updateTemperature: currentTemperature "Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged." recentTemperatures isNil ifTrue: [recentTemperatures := OrderedCollection new. 20 timesRepeat: [recentTemperatures add: 0]]. recentTemperatures removeLast. recentTemperatures addFirst: currentTemperature. temperature := recentTemperatures sum asFloat / recentTemperatures size! ! !BouncingAtomsMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'! descriptionForPartsBin ^ self partName: 'BouncingAtoms' categories: #('Demo') documentation: 'The original, intensively-optimized bouncing-atoms simulation by John Maloney'! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:57'! initialize self registerInFlapsRegistry. ! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:58'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate') forFlapNamed: 'Widgets']! ! !BouncingAtomsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! !BreakpointManager commentStamp: 'emm 5/30/2002 14:20' prior: 0! This class manages methods that include breakpoints. It has several class methods to install and uninstall breakpoints. Evaluating "BreakpointManager clear" will remove all installed breakpoints in the system. Known issues: - currently, only break-on-entry type of breakpoints are supported - emphasis change not implemented for MVC browsers - uninstalling the breakpoint doesn't auto-update other browsers - uninstalling a breakpoint while debugging should restart-simulate the current method Ernest Micklei, 2002 Send comments to emicklei@philemonworks.com! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 5/30/2002 09:37'! installInClass: aClass selector: aSymbol "Install a new method containing a breakpoint. The receiver will remember this for unstalling it later" | breakMethod | breakMethod _ self compilePrototype: aSymbol in: aClass. breakMethod isNil ifTrue: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass methodDictionary at: aSymbol put: breakMethod.! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'emm 4/24/2002 23:24'! unInstall: breakMethod | who oldMethod | oldMethod _ self installed at: breakMethod ifAbsent:[^self]. who _ breakMethod who. (who first methodDictionary at: who last) == breakMethod ifTrue:[ who first methodDictionary at: who last put: oldMethod]. self installed removeKey: breakMethod! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! breakpointMethodSourceFor: aSymbol in: aClass "Compose new source containing a break statement (currently it will be the first, later we want to insert it in any place)" | oldSource methodNode breakOnlyMethodNode sendBreakMessageNode | oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compilerClass new compile: oldSource in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. breakOnlyMethodNode := aClass compilerClass new compile: 'temporaryMethodSelectorForBreakpoint self break. ^self' in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:33'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source node method | source := self breakpointMethodSourceFor: aSymbol in: aClass. node := aClass compilerClass new compile: source in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. node isNil ifTrue: [^nil]. "dunno what the arguments mean..." method := node generate: #(0 0 0 0). ^method! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! installed Installed isNil ifTrue:[Installed := IdentityDictionary new]. ^Installed! ! !BreakpointManager class methodsFor: 'intialization-release' stamp: 'emm 5/30/2002 09:08'! clear "BreakpointManager clear" self installed copy keysDo:[ :breakMethod | self unInstall: breakMethod]. ! ! !BreakpointManager class methodsFor: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'examples' stamp: 'emm 5/30/2002 14:12'! testBreakpoint "In the menu of the methodList, click on -toggle break on entry- and evaluate the following:" "BreakpointManager testBreakpoint" Transcript cr; show: 'Breakpoint test'! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'! testBrowseClass "self debug: #testBrowseClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:56'! testBrowseHierarchyClass "self debug: #testBrowseHierarchyClass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 15:52'! testBrowseHierarchyInstance "self debug: #testBrowseHierarchyInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/11/2004 16:00'! testBrowseHierarchyMataclass "self debug: #testBrowseHierarchyMataclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentHierarchyBrowsers. 1 class class browseHierarchy. browsersAfter := self currentHierarchyBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == Metaclass). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:43'! testBrowseInstance "self debug: #testBrowseInstance" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == SmallInteger). opened delete ! ! !BrowseTest methodsFor: 'testing' stamp: 'mu 3/6/2004 15:44'! testBrowseMetaclass "self debug: #testBrowseMetaclass" | browsersBefore browsersAfter opened | self ensureMorphic. browsersBefore := self currentBrowsers. 1 class class browse. browsersAfter := self currentBrowsers. self assert: (browsersAfter size = (browsersBefore size + 1)). opened := browsersAfter removeAll: browsersBefore; yourself. self assert: (opened size = 1). opened := opened asArray first. self assert: (opened model selectedClass == Metaclass). opened delete ! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:41'! currentBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: Browser]]) asSet! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/11/2004 15:52'! currentHierarchyBrowsers ^ (ActiveWorld submorphs select: [:each | (each isKindOf: SystemWindow) and: [each model isKindOf: HierarchyBrowser]]) asSet! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:27'! ensureMorphic self isMorphic ifFalse: [self error: 'This test should be run in Morphic'].! ! !BrowseTest methodsFor: 'private' stamp: 'mu 3/6/2004 15:26'! isMorphic ^Smalltalk isMorphic! ! !BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'! setUp | systemNavigation | systemNavigation := SystemNavigation default. originalBrowserClass := systemNavigation browserClass. originalHierarchyBrowserClass := systemNavigation hierarchyBrowserClass. systemNavigation browserClass: nil. systemNavigation hierarchyBrowserClass: nil. ! ! !BrowseTest methodsFor: 'running' stamp: 'mu 3/11/2004 15:57'! tearDown | systemNavigation | systemNavigation := SystemNavigation default. systemNavigation browserClass: originalBrowserClass. systemNavigation hierarchyBrowserClass: originalHierarchyBrowserClass.! ! !Browser methodsFor: 'accessing' stamp: 'ls 10/28/2003 12:28'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod _ currentCompiledMethod. currentCompiledMethod _ nil. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass _ self selectedClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: self selectedSystemCategoryName]]. editSelection == #editClass ifTrue: [^ self classDefinitionText ]. editSelection == #editComment ifTrue: [(theClass _ self selectedClass) ifNil: [^ '']. comment _ theClass comment. currentCompiledMethod _ theClass organization commentRemoteStr. ^ comment size = 0 ifTrue: ['This class has not yet been commented.'] ifFalse: [comment]]. editSelection == #hierarchy ifTrue: [^ self selectedClassOrMetaClass printHierarchy]. editSelection == #editMessageCategories ifTrue: [^ self classOrMetaClassOrganizer printString]. editSelection == #newMessage ifTrue: [^ (theClass _ self selectedClassOrMetaClass) ifNil: [''] ifNotNil: [theClass sourceCodeTemplate]]. editSelection == #editMessage ifTrue: [self showingByteCodes ifTrue: [^ self selectedBytecodes]. currentCompiledMethod _ latestCompiledMethod. ^ self selectedMessage]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'nk 3/29/2004 10:11'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString _ input asString. aText _ input asText. editSelection == #editSystemCategories ifTrue: [^ self changeSystemCategories: aString]. editSelection == #editClass | (editSelection == #newClass) ifTrue: [^ self defineClass: aString notifying: aController]. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText stamp: Utilities changeStamp. self changed: #classCommentText. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [self inform: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'drs 1/6/2003 16:11'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" messageCategoryListIndex > 0 & (messageListIndex = 0) ifTrue: [^ 1 to: 500] "entire empty method template" ifFalse: [^ 1 to: 0] "null selection"! ! !Browser methodsFor: 'accessing' stamp: 'nk 2/15/2004 13:27'! editSelection: aSelection "Set the editSelection as requested." editSelection _ aSelection. self changed: #editSelection.! ! !Browser methodsFor: 'accessing' stamp: 'sw 9/26/2002 17:56'! suggestCategoryToSpawnedBrowser: aBrowser "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." (self isMemberOf: Browser) "yecch, but I didn't invent the browser hierarchy" ifTrue: [aBrowser messageCategoryListIndex: (self messageCategoryList indexOf: self categoryOfCurrentMethod ifAbsent: [2])] ifFalse: [aBrowser setOriginalCategoryIndexForCurrentMethod]! ! !Browser methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:00'! annotation "Provide a line of content for an annotation pane, representing information about the method associated with the selected class and selector in the receiver." | aSelector aClass | (aClass _ self selectedClassOrMetaClass) == nil ifTrue: [^ '------']. self editSelection == #editComment ifTrue: [^ self annotationForSelector: #Comment ofClass: aClass]. self editSelection == #editClass ifTrue: [^ self annotationForSelector: #Definition ofClass: aClass]. (aSelector _ self selectedMessageName) ifNil: [^ '------']. ^ self annotationForSelector: aSelector ofClass: aClass! ! !Browser methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:23'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName]. self changed: #messageList ! ! !Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:20'! buildMorphicCommentPane "Construct the pane that shows the class comment. Respect the Preference for standardCodeFont." | commentPane | commentPane := BrowserCommentTextMorph on: self text: #classCommentText accept: #classComment:notifying: readSelection: nil menu: #codePaneMenu:shifted:. commentPane font: Preferences standardCodeFont. ^ commentPane! ! !Browser methodsFor: 'class comment pane' stamp: 'nk 2/15/2004 13:19'! classComment: aText notifying: aPluggableTextMorph "The user has just entered aText. It may be all red (a side-effect of replacing the default comment), so remove the color if it is." | theClass cleanedText redRange | theClass := self selectedClassOrMetaClass. theClass ifNotNil: [cleanedText := aText asText. redRange := cleanedText rangeOf: TextColor red startingAt: 1. redRange size = cleanedText size ifTrue: [cleanedText removeAttribute: TextColor red from: 1 to: redRange last ]. theClass classComment: aText]. self changed: #classCommentText. ^ true! ! !Browser methodsFor: 'class comment pane' stamp: 'bvs 7/20/2004 15:42'! noCommentNagString ^ Preferences browserNagIfNoClassComment ifTrue: [Text string: 'THIS CLASS HAS NO COMMENT!!' translated attribute: TextColor red] ifFalse: [''] ! ! !Browser methodsFor: 'class functions' stamp: 'sd 5/23/2003 14:23'! addAllMethodsToCurrentChangeSet "Add all the methods in the selected class or metaclass to the current change set. You ought to know what you're doing before you invoke this!!" | aClass | (aClass _ self selectedClassOrMetaClass) ifNotNil: [aClass selectors do: [:sel | ChangeSet current adoptSelector: sel forClass: aClass]. self changed: #annotation] ! ! !Browser methodsFor: 'class functions' stamp: 'bvs 7/20/2004 15:40'! classCommentText "return the text to display for the comment of the currently selected class" | theClass | theClass _ self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^ theClass hasComment ifTrue: [ theClass comment ] ifFalse: [ self noCommentNagString ]! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:11'! classDefinitionText "return the text to display for the definition of the currently selected class" | theClass | theClass _ self selectedClassOrMetaClass. theClass ifNil: [ ^'']. ^theClass definitionST80: Preferences printAlternateSyntax not! ! !Browser methodsFor: 'class functions' stamp: 'jon 9/14/2004 09:00'! classListMenu: aMenu shifted: shifted "Set up the menu to apply to the receiver's class list, honoring the #shifted boolean" shifted ifTrue: [^ self shiftedClassListMenu: aMenu]. aMenu addList: #( - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('show hierarchy' hierarchy) ('show definition' editClass) ('show comment' editComment) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('rename class ...' renameClass) ('copy class' copyClass) ('remove class (x)' removeClass) - ('find method...' findMethod) ('find method wildcard...' findMethodWithWildcard) - ('more...' offerShiftedClassListMenu)). ^ aMenu! ! !Browser methodsFor: 'class functions' stamp: 'sw 10/22/2002 16:10'! createInstVarAccessors "Create getters and setters for all inst vars defined at the level of the current class selection, except do NOT clobber or override any selectors already understood by the instances of the selected class" | aClass newMessage setter | (aClass _ self selectedClassOrMetaClass) ifNotNil: [aClass instVarNames do: [:aName | (aClass canUnderstand: aName asSymbol) ifFalse: [newMessage _ aName, ' "Answer the value of ', aName, '" ^ ', aName. aClass compile: newMessage classified: 'accessing' notifying: nil]. (aClass canUnderstand: (setter _ aName, ':') asSymbol) ifFalse: [newMessage _ setter, ' anObject "Set the value of ', aName, '" ', aName, ' _ anObject'. aClass compile: newMessage classified: 'accessing' notifying: nil]]]! ! !Browser methodsFor: 'class functions' stamp: 'sw 11/21/2003 21:45'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens findFirst: [:x | x beginsWith: 'category']. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | '*subclass*' match: x]. newClassName _ (defTokens at: keywdIx+1) copyWithoutAll: '#()'. ((oldClass isNil or: [oldClass theNonMetaClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #systemCategoryList. self changed: #classList. self clearUserEditFlag. self setClass: class selector: nil. "self clearUserEditFlag; editClass." ^ true] ifFalse: [^ false]! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/15/2004 13:23'! editClass "Retrieve the description of the class definition." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #editClass. self changed: #contents. self changed: #classCommentText. ! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:08'! editComment "Retrieve the description of the class comment." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. metaClassIndicated _ false. self editSelection: #editComment. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self decorateButtons. self contentsChanged ! ! !Browser methodsFor: 'class functions' stamp: 'nb 5/6/2003 16:49'! explainSpecial: string "Answer a string explaining the code pane selection if it is displaying one of the special edit functions." | classes whole lits reply | (editSelection == #editClass or: [editSelection == #newClass]) ifTrue: ["Selector parts in class definition" string last == $: ifFalse: [^nil]. lits _ Array with: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.'] ifFalse: [^nil]. classes _ self systemNavigation allClassesImplementing: whole. classes _ 'these classes ' , classes printString. ^reply , ' It is defined in ' , classes , '." Smalltalk browseAllImplementorsOf: #' , whole]. editSelection == #hierarchy ifTrue: ["Instance variables in subclasses" classes _ self selectedClassOrMetaClass allSubclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^'"is an instance variable in class ' , classes , '." ' , classes , ' browseAllAccessesTo: ''' , string , '''.']. editSelection == #editSystemCategories ifTrue: [^nil]. editSelection == #editMessageCategories ifTrue: [^nil]. ^nil! ! !Browser methodsFor: 'class functions' stamp: 'jon 9/12/2004 15:29'! findMethod "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors asSortedArray. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self]. reply := (SelectionMenu labelList: (Array with: 'Enter Wildcard'), selectors lines: #(1) selections: (Array with: 'EnterWildcard'), selectors) startUp. reply == nil ifTrue: [^ self]. reply = 'EnterWildcard' ifTrue: [ reply := FillInTheBlank request: 'Enter partial method name:'. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [ (SelectionMenu labelList: selectors selections: selectors) startUp]. reply == nil ifTrue: [^ self]]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'jon 9/14/2004 08:36'! findMethodWithWildcard "Pop up a list of the current class's methods, and select the one chosen by the user" | aClass selectors reply cat messageCatIndex messageIndex | self classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. aClass := self selectedClassOrMetaClass. selectors := aClass selectors asSortedArray. selectors isEmpty ifTrue: [self inform: aClass name, ' has no methods.'. ^ self]. reply := FillInTheBlank request: 'Enter partial method name:'. (reply isNil or: [reply isEmpty]) ifTrue: [^self]. (reply includes: $*) ifFalse: [reply := '*', reply, '*']. selectors := selectors select: [:each | reply match: each]. selectors isEmpty ifTrue: [self inform: aClass name, ' has no matching methods.'. ^ self]. reply := selectors size = 1 ifTrue: [selectors first] ifFalse: [ (SelectionMenu labelList: selectors selections: selectors) startUp]. reply == nil ifTrue: [^ self]. cat := aClass whichCategoryIncludesSelector: reply. messageCatIndex := self messageCategoryList indexOf: cat. self messageCategoryListIndex: messageCatIndex. messageIndex := (self messageList indexOf: reply). self messageListIndex: messageIndex! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! hierarchy "Display the inheritance hierarchy of the receiver's selected class." classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. self editSelection: #hierarchy. self changed: #editComment. self contentsChanged. ^ self! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:07'! makeNewSubclass self selectedClassOrMetaClass ifNil: [^ self]. self okToChange ifFalse: [^ self]. self editSelection: #newClass. self contentsChanged! ! !Browser methodsFor: 'class functions' stamp: 'nk 2/14/2004 15:09'! plusButtonHit "Cycle among definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [self editSelection: #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^ self]. self editComment! ! !Browser methodsFor: 'class functions' stamp: 'sw 3/5/2001 18:04'! removeClass "If the user confirms the wish to delete the class, do so" super removeClass ifTrue: [self classListIndex: 0]! ! !Browser methodsFor: 'class functions' stamp: 'sd 4/29/2003 11:49'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. "Cancel returns ''" newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ self systemNavigation allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [self systemNavigation browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]! ! !Browser methodsFor: 'class functions' stamp: 'sw 10/16/2002 15:41'! shiftedClassListMenu: aMenu "Set up the menu to apply to the receiver's class list when the shift key is down" ^ aMenu addList: #( - ('unsent methods' browseUnusedMethods 'browse all methods defined by this class that have no senders') ('unreferenced inst vars' showUnreferencedInstVars 'show a list of all instance variables that are not referenced in methods') ('unreferenced class vars' showUnreferencedClassVars 'show a list of all class variables that are not referenced in methods') ('subclass template' makeNewSubclass 'put a template into the code pane for defining of a subclass of this class') - ('sample instance' makeSampleInstance 'give me a sample instance of this class, if possible') ('inspect instances' inspectInstances 'open an inspector on all the extant instances of this class') ('inspect subinstances' inspectSubInstances 'open an inspector on all the extant instances of this class and of all of its subclasses') - ('fetch documentation' fetchClassDocPane 'once, and maybe again someday, fetch up-to-date documentation for this class from the Squeak documentation repository') ('add all meths to current chgs' addAllMethodsToCurrentChangeSet 'place all the methods defined by this class into the current change set') ('create inst var accessors' createInstVarAccessors 'compile instance-variable access methods for any instance variables that do not yet have them') - ('more...' offerUnshiftedClassListMenu 'return to the standard class-list menu'))! ! !Browser methodsFor: 'class list' stamp: 'nk 2/14/2004 15:07'! classListIndex: anInteger "Set anInteger to be the index of the current class selection." | className | classListIndex _ anInteger. self setClassOrganizer. messageCategoryListIndex _ 0. messageListIndex _ 0. self classCommentIndicated ifTrue: [] ifFalse: [self editSelection: (anInteger = 0 ifTrue: [metaClassIndicated | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. contents _ nil. self selectedClass isNil ifFalse: [className _ self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classCommentText. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! recent "Let the user select from a list of recently visited classes. 11/96 stp. 12/96 di: use class name, not classes themselves. : dont fall into debugger in empty case" | className class recentList | recentList _ RecentClasses select: [:n | Smalltalk includesKey: n]. recentList size == 0 ifTrue: [^ Beeper beep]. className := (SelectionMenu selections: recentList) startUp. className == nil ifTrue: [^ self]. class := Smalltalk at: className. self selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !Browser methodsFor: 'code pane' stamp: 'asm 6/25/2003 22:48'! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName ifNil: [ self selectOriginalCategoryForCurrentMethod ifFalse:["Select the '--all--' category" self messageCategoryListIndex: 1]]. self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex _ messageCategoryListIndex. fallBackMethodIndex _ messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex _ 0. (result _ self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName _ self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex _ fallBackMethodIndex _ self messageList indexOf: originalSelectorName. (result _ self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'code pane' stamp: 'sw 5/18/2001 20:55'! showBytecodes "Show or hide the bytecodes of the selected method -- an older protocol now mostly not relevant." self toggleShowingByteCodes! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 17:43'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph "Here we are fetching informations from the dropped transferMorph and performing the correct action for this drop." | srcType success srcBrowser | success := false. srcType := transferMorph dragTransferType. srcBrowser := transferMorph source model. srcType == #messageList ifTrue: [ | srcClass srcSelector srcCategory | srcClass := transferMorph passenger key. srcSelector := transferMorph passenger value. srcCategory := srcBrowser selectedMessageCategoryName. srcCategory ifNil: [srcCategory := srcClass organization categoryOfElement: srcSelector]. success := self acceptMethod: srcSelector messageCategory: srcCategory class: srcClass atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. srcType == #classList ifTrue: [success := self changeCategoryForClass: transferMorph passenger srcSystemCategory: srcBrowser selectedSystemCategoryName atListMorph: dstListMorph internal: self == srcBrowser copy: transferMorph shouldCopy]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 4/22/2004 18:00'! changeMessageCategoryForMethod: methodSel dstMessageCategory: dstMessageCategorySel srcMessageCategory: srcMessageCategorySel insideClassOrMeta: classOrMeta internal: internal copySemantic: copyFlag "Recategorize the method named by methodSel. If the dstMessageCategorySel is the allCategory, then recategorize it from its parents." | success messageCategorySel | copyFlag ifTrue: [^ false]. "only move semantic" messageCategorySel := dstMessageCategorySel ifNil: [srcMessageCategorySel]. (success := messageCategorySel notNil and: [messageCategorySel ~= srcMessageCategorySel]) ifTrue: [success := messageCategorySel == ClassOrganizer allCategory ifTrue: [self recategorizeMethodSelector: methodSel] ifFalse: [(classOrMeta organization categories includes: messageCategorySel) and: [classOrMeta organization classify: methodSel under: messageCategorySel suppressIfDefault: false. true]]]. success ifTrue: [self changed: #messageList. internal ifFalse: [self setSelector: methodSel]]. ^ success! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:32'! dragPassengerFor: item inMorph: dragSource | transferType smn | (dragSource isKindOf: PluggableListMorph) ifFalse: [^nil]. transferType _ self dragTransferTypeForMorph: dragSource. transferType == #classList ifTrue: [^self selectedClass]. transferType == #messageList ifFalse: [ ^nil ]. smn _ self selectedMessageName ifNil: [ ^nil ]. (MessageSet isPseudoSelector: smn) ifTrue: [ ^nil ]. ^ self selectedClassOrMetaClass -> smn. ! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:21'! dstCategoryDstListMorph: dstListMorph ^(dstListMorph getListSelector == #systemCategoryList) ifTrue: [dstListMorph potentialDropItem ] ifFalse: [self selectedSystemCategoryName]! ! !Browser methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:20'! dstClassDstListMorph: dstListMorph | dropItem | ^(dstListMorph getListSelector == #classList) ifTrue: [(dropItem _ dstListMorph potentialDropItem) ifNotNil: [Smalltalk at: dropItem withBlanksCondensed asSymbol]] ifFalse: [dstListMorph model selectedClass]! ! !Browser methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 06:16'! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem _ dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 3/24/2004 11:50'! addAListPane: aListPane to: window at: nominalFractions plus: verticalOffset | row switchHeight divider | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; layoutPolicy: ProportionalLayout new. switchHeight _ 25. self addMorphicSwitchesTo: row at: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@(1-switchHeight) corner: 0@0) ). divider _ BorderedSubpaneDividerMorph forTopEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. row addMorph: divider fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@switchHeight negated corner: 0@(1-switchHeight)) ). row addMorph: aListPane fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@0 corner: 0@(switchHeight negated)) ). window addMorph: row fullFrame: ( LayoutFrame fractions: nominalFractions offsets: (0@verticalOffset corner: 0@0) ). row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:31'! browseSelectionInPlace "In place code - incomplete" " self systemCategoryListIndex: (self systemCategoryList indexOf: self selectedClass category). self classListIndex: (self classList indexOf: self selectedClass name)" self spawnHierarchy.! ! !Browser methodsFor: 'initialize-release' stamp: 'rww 8/18/2002 09:27'! buildMorphicClassList | myClassList | (myClassList _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightClassList:with:; on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. myClassList borderWidth: 0. myClassList enableDragNDrop: Preferences browseWithDragNDrop. myClassList doubleClickSelector: #browseSelectionInPlace. ^myClassList ! ! !Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:37'! buildMorphicMessageCatList | myMessageCatList | (myMessageCatList _ PluggableMessageCategoryListMorph new) setProperty: #highlightSelector toValue: #highlightMessageCategoryList:with:; on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList. myMessageCatList enableDragNDrop: Preferences browseWithDragNDrop. ^myMessageCatList ! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 6/5/2001 20:01'! buildMorphicMessageList "Build a morphic message list, with #messageList as its list-getter" | aListMorph | (aListMorph _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightMessageList:with:; setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForMethodString; on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: Preferences browseWithDragNDrop. aListMorph menuTitleSelector: #messageListSelectorTitle. ^aListMorph ! ! !Browser methodsFor: 'initialize-release' stamp: 'dew 3/8/2002 00:05'! buildMorphicSwitches | instanceSwitch divider1 divider2 commentSwitch classSwitch row aColor | instanceSwitch _ PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'instance'; askBeforeChanging: true; borderWidth: 0. commentSwitch _ PluggableButtonMorph on: self getState: #classCommentIndicated action: #plusButtonHit. commentSwitch label: '?' asText allBold; askBeforeChanging: true; setBalloonText: 'class comment'; borderWidth: 0. classSwitch _ PluggableButtonMorph on: self getState: #classMessagesIndicated action: #indicateClassMessages. classSwitch label: 'class'; askBeforeChanging: true; borderWidth: 0. divider1 := BorderedSubpaneDividerMorph vertical. divider2 := BorderedSubpaneDividerMorph vertical. Preferences alternativeWindowLook ifTrue:[ divider1 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent. divider2 extent: 4@4; borderWidth: 2; borderRaised; color: Color transparent. ]. row _ AlignmentMorph newRow hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; addMorphBack: instanceSwitch; addMorphBack: divider1; addMorphBack: commentSwitch; addMorphBack: divider2; addMorphBack: classSwitch. aColor _ Color colorFrom: self defaultBackgroundColor. row color: aColor duller. "ensure matching button divider color. (see #paneColor)" Preferences alternativeWindowLook ifTrue:[aColor _ aColor muchLighter]. {instanceSwitch. commentSwitch. classSwitch} do: [:m | m color: aColor; onColor: aColor twiceDarker offColor: aColor; hResizing: #spaceFill; vResizing: #spaceFill. ]. ^ row ! ! !Browser methodsFor: 'initialize-release' stamp: 'RAA 2/9/2001 16:34'! buildMorphicSystemCatList | dragNDropFlag myCatList | dragNDropFlag _ Preferences browseWithDragNDrop. (myCatList _ PluggableListMorph new) setProperty: #highlightSelector toValue: #highlightSystemCategoryList:with:; on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. myCatList enableDragNDrop: dragNDropFlag. ^myCatList ! ! !Browser methodsFor: 'initialize-release' stamp: 'nk 2/13/2001 13:25'! labelString ^self selectedClass ifNil: [ self defaultBrowserTitle ] ifNotNil: [ self defaultBrowserTitle, ': ', self selectedClass printString ]. ! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 4/3/2004 19:38'! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window dragNDropFlag hSepFrac switchHeight mySingletonClassList | window _ (SystemWindow labelled: 'later') model: self. dragNDropFlag _ Preferences browseWithDragNDrop. hSepFrac _ 0.3. switchHeight _ 25. mySingletonClassList _ PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:shifted: keystroke: #classListKey:from:. mySingletonClassList enableDragNDrop: dragNDropFlag. self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window addMorph: mySingletonClassList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@0) offsets: (0@0 corner: 0@switchHeight) ). self addMorphicSwitchesTo: window at: ( LayoutFrame fractions: (0.5@0 corner: 1.0@0) offsets: (0@0 corner: 0@switchHeight) ). window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0@0 corner: 0.5@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.5@0 corner: 1.0@hSepFrac) offsets: (0@switchHeight corner: 0@0) ). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialize-release' stamp: 'sps 4/3/2004 20:41'! openAsMorphEditing: editString "Create a pluggable version of all the morphs for a Browser in Morphic" | window hSepFrac | hSepFrac _ 0.4. window _ (SystemWindow labelled: 'later') model: self. "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. " Preferences scrollBarsOnRight ifFalse: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window addMorph: self buildMorphicSystemCatList frame: (0@0 corner: 0.25@hSepFrac). self addClassAndSwitchesTo: window at: (0.25@0 corner: 0.5@hSepFrac) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.5@0 extent: 0.25@hSepFrac). window addMorph: self buildMorphicMessageList frame: (0.75@0 extent: 0.25@hSepFrac). Preferences scrollBarsOnRight ifTrue: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window ! ! !Browser methodsFor: 'initialize-release' stamp: 'nk 4/28/2004 10:17'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window hSepFrac switchHeight mySingletonList nextOffsets | window _ (SystemWindow labelled: 'later') model: self. hSepFrac _ 0.30. switchHeight _ 25. mySingletonList _ PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. mySingletonList enableDragNDrop: Preferences browseWithDragNDrop. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@0) offsets: (0@0 corner: 0@switchHeight) ). self addClassAndSwitchesTo: window at: (0@0 corner: 0.3333@hSepFrac) plus: switchHeight. nextOffsets _ 0@switchHeight corner: 0@0. window addMorph: self buildMorphicMessageCatList fullFrame: ( LayoutFrame fractions: (0.3333@0 corner: 0.6666@hSepFrac) offsets: nextOffsets ). window addMorph: self buildMorphicMessageList fullFrame: ( LayoutFrame fractions: (0.6666@0 corner: 1@hSepFrac) offsets: nextOffsets ). self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString. window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'tween 8/27/2004 12:01'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView underPane y optionalButtonsView annotationPane | self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString]. "Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString]. uncomment-out for testing morphic browser embedded in mvc project" topView _ StandardSystemView new model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:. systemCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 50 @ 62). topView addSubView: classListView toRightOf: systemCategoryListView. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView controller terminateDuringSelect: true. messageCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 50 @ 70). messageListView menuTitleSelector: #messageListSelectorTitle. topView addSubView: messageListView toRightOf: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: systemCategoryListView. underPane _ annotationPane. y _ 110 - self optionalAnnotationHeight] ifFalse: [ underPane _ systemCategoryListView. y _ 110]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'tween 8/27/2004 12:01'! openMessageCatEditString: aString "Create a pluggable version of the views for a Browser that just shows one message category." | messageCategoryListView messageListView browserCodeView topView annotationPane underPane y optionalButtonsView | self couldOpenInMorphic ifTrue: [^ self openAsMorphMsgCatEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" messageCategoryListView _ PluggableListView on: self list: #messageCatListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: messageCategoryListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 200 @ 70). topView addSubView: messageListView below: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageListView. underPane _ annotationPane. y _ (200 - 12 - 70) - self optionalAnnotationHeight] ifFalse: [underPane _ messageListView. y _ (200 - 12 - 70)]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(messageCatListSingleton messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'tween 8/27/2004 12:02'! openMessageEditString: aString "Create a pluggable version of the views for a Browser that just shows one message." | messageListView browserCodeView topView annotationPane underPane y | Smalltalk isMorphic ifTrue: [^ self openAsMorphMessageEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" messageListView _ PluggableListView on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted:. messageListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: messageListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageListView. underPane _ annotationPane. y _ (200 - 12) - self optionalAnnotationHeight] ifFalse: [underPane _ messageListView. y _ 200 - 12]. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'tween 8/27/2004 12:02'! openOnClassWithEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | classListView messageCategoryListView messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView | Smalltalk isMorphic ifTrue: [^ self openAsMorphClassEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" classListView _ PluggableListView on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 100 @ 12). topView addSubView: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 100 @ 70). topView addSubView: messageCategoryListView below: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 100 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. switchView window: switchView window viewport: (classListView viewport topRight corner: messageListView viewport topRight). topView addSubView: switchView toRightOf: classListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageCategoryListView. underPane _ annotationPane. y _ (200-12-70) - self optionalAnnotationHeight] ifFalse: [underPane _ messageCategoryListView. y _ (200-12-70)]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'tween 8/27/2004 12:02'! openSystemCatEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers. The top list view is of the currently selected system class category--a single item list." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView y annotationPane underPane optionalButtonsView | Smalltalk isMorphic ifTrue: [^ self openAsMorphSysCatEditing: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. "label and minSize taken care of by caller" systemCategoryListView _ PluggableListView on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. systemCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 67 @ 62). topView addSubView: classListView below: systemCategoryListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView controller terminateDuringSelect: true. messageCategoryListView window: (0 @ 0 extent: 66 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. switchView _ self buildInstanceClassSwitchView. switchView window: switchView window viewport: (classListView viewport bottomLeft corner: messageCategoryListView viewport bottomLeft). switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 67 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: switchView. y _ 110 - 12 - self optionalAnnotationHeight. underPane _ annotationPane] ifFalse: [y _ 110 - 12. underPane _ switchView]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 23:23'! setClass: aBehavior selector: aSymbol "Set the state of a new, uninitialized Browser." | isMeta aClass messageCatIndex | aBehavior ifNil: [^ self]. (aBehavior isKindOf: Metaclass) ifTrue: [ isMeta _ true. aClass _ aBehavior soleInstance] ifFalse: [ isMeta _ false. aClass _ aBehavior]. self selectCategoryForClass: aClass. self classListIndex: ( (SystemOrganization listAtCategoryNamed: self selectedSystemCategoryName) indexOf: aClass name). self metaClassIndicated: isMeta. aSymbol ifNil: [^ self]. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: (messageCatIndex > 0 ifTrue: [messageCatIndex + 1] ifFalse: [0]). messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ( (aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol).! ! !Browser methodsFor: 'initialize-release' stamp: 'rhi 5/12/2004 15:00'! systemOrganizer: aSystemOrganizer "Initialize the receiver as a perspective on the system organizer, aSystemOrganizer. Typically there is only one--the system variable SystemOrganization." contents _ nil. systemOrganizer _ aSystemOrganizer. systemCategoryListIndex _ 0. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. metaClassIndicated _ false. self setClassOrganizer. self editSelection: #none.! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:47'! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. self classOrMetaClassOrganizer sortCategories. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'nk 6/13/2004 07:21'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." "wod 6/24/1998: set newBrowser classListIndex so that it works whether the receiver is a standard or a Hierarchy Browser." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser _ Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. self class openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'sw 2/22/2001 06:54'! categoryOfCurrentMethod "Determine the method category associated with the receiver at the current moment, or nil if none" | aCategory | ^ super categoryOfCurrentMethod ifNil: [(aCategory _ self messageCategoryListSelection) == ClassOrganizer allCategory ifTrue: [nil] ifFalse: [aCategory]]! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 22:56'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'nk 2/14/2004 15:06'! editMessageCategories "Indicate to the receiver and its dependents that the message categories of the selected class have been changed." self okToChange ifFalse: [^ self]. classListIndex ~= 0 ifTrue: [self messageCategoryListIndex: 0. self editSelection: #editMessageCategories. self changed: #editMessageCategories. self contentsChanged]! ! !Browser methodsFor: 'message category functions' stamp: 'emm 5/30/2002 09:20'! highlightMessageList: list with: morphList "Changed by emm to add emphasis in case of breakpoint" morphList do:[:each | | classOrNil methodOrNil | classOrNil := self selectedClassOrMetaClass. methodOrNil := classOrNil isNil ifTrue:[nil] ifFalse:[classOrNil methodDictionary at: each contents ifAbsent:[]]. (methodOrNil notNil and:[methodOrNil hasBreakpoint]) ifTrue:[each contents: ((each contents ,' [break]') asText allBold)]]! ! !Browser methodsFor: 'message category functions' stamp: 'dew 9/20/2001 00:21'! messageCategoryMenu: aMenu ^ aMenu labels: 'browse printOut fileOut reorganize alphabetize remove empty categories categorize all uncategorized new category... rename... remove' lines: #(3 8) selections: #(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories editMessageCategories alphabetizeMessageCategories removeEmptyCategories categorizeAllUncategorizedMethods addCategory renameCategory removeMessageCategory) ! ! !Browser methodsFor: 'message category functions' stamp: 'nk 4/23/2004 09:18'! removeEmptyCategories self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'message category functions' stamp: 'NS 4/7/2004 23:01'! renameCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self]. oldName _ self selectedMessageCategoryName. newName _ self request: 'Please type new category name' initialAnswer: oldName. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. newName = oldName ifTrue: [^ self]. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/8/2001 15:08'! showHomeCategory "Show the home category of the selected method. This is only really useful if one is in a tool that supports the showing of categories. Thus, it's good in browsers and hierarchy browsers but not in message-list browsers" | aSelector | self okToChange ifTrue: [(aSelector _ self selectedMessageName) ifNotNil: [self selectOriginalCategoryForCurrentMethod. self selectedMessageName: aSelector]]! ! !Browser methodsFor: 'message category list' stamp: 'nk 11/30/2002 08:20'! categorizeAllUncategorizedMethods "Categorize methods by looking in parent classes for a method category." | organizer organizers | organizer _ self classOrMetaClassOrganizer. organizers _ self selectedClassOrMetaClass withAllSuperclasses collect: [:ea | ea organization]. (organizer listAtCategoryNamed: ClassOrganizer default) do: [:sel | | found | found _ (organizers collect: [ :org | org categoryOfElement: sel]) detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] ifNone: []. found ifNotNil: [organizer classify: sel under: found]]. self changed: #messageCategoryList! ! !Browser methodsFor: 'message category list' stamp: 'rhi 5/12/2004 19:36'! messageCategoryListIndex: anInteger "Set the selected message category to be the one indexed by anInteger." messageCategoryListIndex _ anInteger. messageListIndex _ 0. self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self editSelection: (anInteger > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]). contents _ nil. self contentsChanged.! ! !Browser methodsFor: 'message category list' stamp: 'nk 4/22/2004 17:59'! recategorizeMethodSelector: sel "Categorize method named sel by looking in parent classes for a method category. Answer true if recategorized." | thisCat | self selectedClassOrMetaClass allSuperclasses do: [:ea | thisCat := ea organization categoryOfElement: sel. (thisCat ~= ClassOrganizer default and: [thisCat notNil]) ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat. self changed: #messageCategoryList. ^ true]]. ^ false! ! !Browser methodsFor: 'message category list' stamp: 'nk 6/13/2004 06:20'! selectMessageCategoryNamed: aSymbol "Given aSymbol, select the category with that name. Do nothing if aSymbol doesn't exist." self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol ifAbsent: [ 1])! ! !Browser methodsFor: 'message category list' stamp: 'KLC 2/20/2004 08:08'! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol selectorName | aSymbol _ self categoryOfCurrentMethod. selectorName _ self selectedMessageName. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [messageCategoryListIndex _ (self messageCategoryList indexOf: aSymbol). messageListIndex _ (self messageList indexOf: selectorName). self changed: #messageCategorySelectionChanged. self changed: #messageCategoryListIndex. "update my selection" self changed: #messageList. self changed: #messageListIndex. ^ true]. ^ false! ! !Browser methodsFor: 'message functions' stamp: 'sd 1/5/2002 21:11'! buildMessageBrowserEditString: aString "Create and schedule a message browser for the receiver in which the argument, aString, contains characters to be edited in the text view." messageListIndex = 0 ifTrue: [^ self]. ^ self class openMessageBrowserForClass: self selectedClassOrMetaClass selector: self selectedMessageName editString: aString! ! !Browser methodsFor: 'message functions' stamp: 'emm 5/30/2002 10:25'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" "Changed by emm to include menu-item for breakpoints" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList:#( ('what to show...' offerWhatToShowMenu) ('toggle break on entry' toggleBreakOnEntry) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('tile scriptor' openSyntaxView) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'message functions' stamp: 'sd 5/11/2003 21:01'! removeMessage "If a message is selected, create a Confirmer so the user can verify that the currently selected message should be removed from the system. If so, remove it. If the Preference 'confirmMethodRemoves' is set to false, the confirmer is bypassed." | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: self selectedMessageName. self messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! !Browser methodsFor: 'message functions' stamp: 'sw 1/16/2002 21:54'! shiftedMessageListMenu: aMenu "Fill aMenu with the items appropriate when the shift key is held down" Smalltalk isMorphic ifTrue: [aMenu addStayUpItem]. aMenu addList: #( ('method pane' makeIsolatedCodePane) ('tile scriptor' openSyntaxView) ('toggle diffing (D)' toggleDiffing) ('implementors of sent messages' browseAllMessages) - ('local senders of...' browseLocalSendersOfMessages) ('local implementors of...' browseLocalImplementors) - ('spawn sub-protocol' spawnProtocol) ('spawn full protocol' spawnFullProtocol) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances)). self addExtraShiftedItemsTo: aMenu. aMenu addList: #( - ('change category...' changeCategory)). self canShowMultipleMessageCategories ifTrue: [aMenu addList: #(('show category (C)' showHomeCategory))]. aMenu addList: #( - ('change sets with this method' findMethodInChangeSets) ('revert to previous version' revertToPreviousVersion) ('remove from current change set' removeFromCurrentChanges) ('revert & remove from changes' revertAndForget) ('add to current change set' adoptMessageInCurrentChangeset) ('copy up or copy down...' copyUpOrCopyDown) - ('fetch documentation' fetchDocPane) ('more...' unshiftedYellowButtonActivity)). ^ aMenu ! ! !Browser methodsFor: 'message list' stamp: 'drs 1/1/2003 23:33'! messageList "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." | sel | (sel _ self messageCategoryListSelection) ifNil: [ ^ self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors] "^ Array new" ]. ^ sel = ClassOrganizer allCategory ifTrue: [self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]] ifFalse: [(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1) ifNil: [messageCategoryListIndex _ 0. Array new]]! ! !Browser methodsFor: 'message list' stamp: 'rhi 5/12/2004 19:35'! messageListIndex: anInteger "Set the selected message selector to be the one indexed by anInteger." messageListIndex _ anInteger. self editSelection: (anInteger > 0 ifTrue: [#editMessage] ifFalse: [self messageCategoryListIndex > 0 ifTrue: [#newMessage] ifFalse: [self classListIndex > 0 ifTrue: [#editClass] ifFalse: [#newClass]]]). contents _ nil. self changed: #messageListIndex. "update my selection" self contentsChanged. self decorateButtons.! ! !Browser methodsFor: 'message list' stamp: 'nk 6/19/2004 16:44'! selectedMessage "Answer a copy of the source code for the selected message." | class selector method | contents == nil ifFalse: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. ^ contents _ (self showingDocumentation ifFalse: [ self sourceStringPrettifiedAndDiffed ] ifTrue: [ self commentContents ]) copy asText makeSelectorBoldIn: class! ! !Browser methodsFor: 'message list' stamp: 'tpr 5/6/2003 14:05'! selectedMessageName "Answer the message selector of the currently selected message, if any. Answer nil otherwise." | aList | messageListIndex = 0 ifTrue: [^ nil]. ^ (aList _ self messageList) size >= messageListIndex ifTrue: [aList at: messageListIndex] ifFalse: [nil]! ! !Browser methodsFor: 'message list' stamp: 'sw 10/8/2001 13:37'! selectedMessageName: aSelector "Make the given selector be the selected message name" | anIndex | anIndex _ self messageList indexOf: aSelector. anIndex > 0 ifTrue: [self messageListIndex: anIndex]! ! !Browser methodsFor: 'metaclass' stamp: 'nk 2/14/2004 15:08'! metaClassIndicated: trueOrFalse "Indicate whether browsing instance or class messages." metaClassIndicated _ trueOrFalse. self setClassOrganizer. systemCategoryListIndex > 0 ifTrue: [self editSelection: (classListIndex = 0 ifTrue: [metaClassIndicated ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass])]. messageCategoryListIndex _ 0. messageListIndex _ 0. contents _ nil. self changed: #classSelectionChanged. self changed: #messageCategoryList. self changed: #messageList. self changed: #contents. self changed: #annotation. self decorateButtons ! ! !Browser methodsFor: 'system category functions' stamp: 'je 4/30/2001 17:59'! addSystemCategory "Prompt for a new category name and add it before the current selection, or at the end if no current selection" | oldIndex newName | self okToChange ifFalse: [^ self]. oldIndex _ systemCategoryListIndex. newName _ self request: 'Please type new category name' initialAnswer: 'Category-Name'. newName isEmpty ifTrue: [^ self] ifFalse: [newName _ newName asSymbol]. systemOrganizer addCategory: newName before: (systemCategoryListIndex = 0 ifTrue: [nil] ifFalse: [self selectedSystemCategoryName]). self systemCategoryListIndex: (oldIndex = 0 ifTrue: [self systemCategoryList size] ifFalse: [oldIndex]). self changed: #systemCategoryList.! ! !Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:38'! alphabetizeSystemCategories self okToChange ifFalse: [^ false]. systemOrganizer sortCategories. self systemCategoryListIndex: 0. self changed: #systemCategoryList. ! ! !Browser methodsFor: 'system category functions' stamp: 'sd 1/5/2002 21:11'! browseAllClasses "Create and schedule a new browser on all classes alphabetically." | newBrowser | newBrowser _ HierarchyBrowser new initAlphabeticListing. self class openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'All Classes Alphabetically'! ! !Browser methodsFor: 'system category functions' stamp: 'sd 1/5/2002 21:12'! buildSystemCategoryBrowserEditString: aString "Create and schedule a new system category browser with initial textual contents set to aString." | newBrowser | systemCategoryListIndex > 0 ifTrue: [newBrowser _ self class new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser setClass: self selectedClassOrMetaClass selector: self selectedMessageName. self class openBrowserView: (newBrowser openSystemCatEditString: aString) label: 'Classes in category ', newBrowser selectedSystemCategoryName]! ! !Browser methodsFor: 'system category functions' stamp: 'nk 2/14/2004 15:09'! editSystemCategories "Retrieve the description of the class categories of the system organizer." self okToChange ifFalse: [^ self]. self systemCategoryListIndex: 0. self editSelection: #editSystemCategories. self changed: #editSystemCategories. self contentsChanged! ! !Browser methodsFor: 'system category functions' stamp: 'brp 8/4/2003 21:32'! systemCategoryMenu: aMenu ^ aMenu labels: 'find class... (f) recent classes... (r) browse all browse printOut fileOut reorganize alphabetize update add item... rename... remove' lines: #(2 4 6 8) selections: #(findClass recent browseAllClasses buildSystemCategoryBrowser printOutSystemCategory fileOutSystemCategory editSystemCategories alphabetizeSystemCategories updateSystemCategories addSystemCategory renameSystemCategory removeSystemCategory )! ! !Browser methodsFor: 'system category list' stamp: 'nk 2/14/2004 15:06'! systemCategoryListIndex: anInteger "Set the selected system category index to be anInteger. Update all other selections to be deselected." systemCategoryListIndex _ anInteger. classListIndex _ 0. messageCategoryListIndex _ 0. messageListIndex _ 0. self editSelection: ( anInteger = 0 ifTrue: [#none] ifFalse: [#newClass]). metaClassIndicated _ false. self setClassOrganizer. contents _ nil. self changed: #systemCategorySelectionChanged. self changed: #systemCategoryListIndex. "update my selection" self changed: #classList. self changed: #messageCategoryList. self changed: #messageList. self changed: #relabel. self contentsChanged! ! !Browser methodsFor: 'construction' stamp: 'nk 2/15/2004 13:49'! addLowerPanesTo: window at: nominalFractions with: editString | commentPane | super addLowerPanesTo: window at: nominalFractions with: editString. commentPane _ self buildMorphicCommentPane. window addMorph: commentPane fullFrame: (LayoutFrame fractions: (0@0.75 corner: 1@1)). self changed: #editSelection.! ! !Browser methodsFor: 'user interface' stamp: 'hpt 9/30/2004 20:51'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" super addModelItemsToWindowMenu: aMenu. SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 2/2/2004 13:50'! fullOnClass: aClass "Open a new full browser set to class." | brow | brow _ self new. brow setClass: aClass selector: nil. ^ self openBrowserView: (brow openEditString: nil) label: 'System Browser'! ! !Browser class methodsFor: 'instance creation' stamp: 'hpt 8/5/2004 20:11'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow classToUse | classToUse _ SystemBrowser default. brow _ classToUse new. brow setClass: aClass selector: aSelector. ^ classToUse openBrowserView: (brow openEditString: nil) label: brow labelString! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12'! newOnCategory: aCategory "Browse the system category of the given name. 7/13/96 sw" "Browser newOnCategory: 'Interface-Browser'" | newBrowser catList | newBrowser _ self new. catList _ newBrowser systemCategoryList. newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). ^ self openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'Classes in category ', aCategory ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12'! newOnClass: aClass label: aLabel "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: nil. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: aLabel ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:12'! newOnClass: aClass selector: aSymbol "Open a new class browser on this class." | newBrowser | newBrowser _ self new. newBrowser setClass: aClass selector: aSymbol. ^ self openBrowserView: (newBrowser openOnClassWithEditString: nil) label: 'Class Browser: ', aClass name ! ! !Browser class methodsFor: 'instance creation' stamp: 'jcg 10/29/2003 23:11'! openBrowser "Create and schedule a BrowserView with default browser label. The view consists of five subviews, starting with the list view of system categories of SystemOrganization. The initial text view part is empty." | br | br := self new. ^ self openBrowserView: (br openEditString: nil) label: br defaultBrowserTitle. ! ! !Browser class methodsFor: 'instance creation' stamp: 'sps 3/9/2004 15:54'! openBrowserView: aBrowserView label: aString "Schedule aBrowserView, labelling the view aString." aBrowserView isMorph ifTrue: [(aBrowserView setLabel: aString) openInWorld] ifFalse: [aBrowserView label: aString. aBrowserView minimumSize: 300 @ 200. aBrowserView subViews do: [:each | each controller]. aBrowserView controller open]. ^ aBrowserView model ! ! !Browser class methodsFor: 'instance creation' stamp: 'sd 1/5/2002 21:10'! openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString "Create and schedule a message browser for the class, aBehavior, in which the argument, aString, contains characters to be edited in the text view. These characters are the source code for the message selector aSymbol." | newBrowser | (newBrowser _ self new) setClass: aBehavior selector: aSymbol. ^ self openBrowserView: (newBrowser openMessageEditString: aString) label: newBrowser selectedClassOrMetaClassName , ' ' , newBrowser selectedMessageName ! ! !Browser class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:38'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" | aWindow | aWindow _ self new openAsMorphEditing: nil. aWindow setLabel: 'System Browser'; applyModelExtent. ^ aWindow! ! !Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:41'! initialize "Browser initialize" RecentClasses := OrderedCollection new. self registerInFlapsRegistry; registerInAppRegistry ! ! !Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:41'! registerInAppRegistry "Register the receiver in the SystemBrowser AppRegistry" SystemBrowser register: self.! ! !Browser class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:32'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(#Browser #prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system' ) forFlapNamed: 'Tools']! ! !Browser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 19:42'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]. SystemBrowser unregister: self.! ! !Browser class methodsFor: 'window color' stamp: 'sw 2/26/2002 13:46'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Browser' brightColor: #lightGreen pastelColor: #paleGreen helpMessage: 'The standard "system browser" tool that allows you to browse through all the code in the system'! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 13:41'! hideOrShowPane (self model editSelection == #editClass) ifTrue: [ self showPane ] ifFalse: [ self hidePane ]! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 14:08'! hidePane | win | self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame bottomFraction ]. win _ self window ifNil: [ ^self ]. self delete. win updatePanesFromSubmorphs.! ! !BrowserCommentTextMorph methodsFor: 'displaying' stamp: 'nk 2/15/2004 14:09'! showPane owner ifNil: [ | win | win _ self window ifNil: [ ^self ]. win addMorph: self fullFrame: self layoutFrame. win updatePanesFromSubmorphs ]. self lowerPane ifNotNilDo: [ :lp | lp layoutFrame bottomFraction: self layoutFrame topFraction ]! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 14:11'! noteNewOwner: win super noteNewOwner: win. self setProperty: #browserWindow toValue: win. win ifNil: [ ^self ]. win setProperty: #browserClassCommentPane toValue: self. self setProperty: #browserLowerPane toValue: (win submorphThat: [ :m | m isAlignmentMorph and: [ m layoutFrame bottomFraction = 1 ]] ifNone: []). ! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'nk 2/15/2004 13:42'! update: anAspect super update: anAspect. anAspect == #editSelection ifFalse: [ ^self ]. self hideOrShowPane! ! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:12'! lowerPane "Answer the AlignmentMorph that I live beneath" ^self valueOfProperty: #browserLowerPane! ! !BrowserCommentTextMorph methodsFor: 'accessing' stamp: 'nk 2/15/2004 14:07'! window ^self owner ifNil: [ self valueOfProperty: #browserWindow ].! ! !BrowserCommentTextMorph commentStamp: '' prior: 0! I am a PluggableTextMorph that knows enough to make myself invisible when necessary.! !ButtonPhaseType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #ButtonPhase. symbols _ #(buttonDown whilePressed buttonUp)! ! !ButtonPhaseType methodsFor: 'color' stamp: 'sw 9/27/2001 17:20'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.806 1.0 0.806) ! ! !ButtonPhaseType methodsFor: 'queries' stamp: 'mir 7/15/2004 10:35'! representsAType "Answer whether this vocabulary represents an end-user-sensible data type" ^true! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'! actWhen ^ actWhen! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 09:43'! actWhen: condition (#(buttonDown mouseDown) includes: condition) ifTrue: [ actWhen _ #mouseDown ]. (#(buttonUp mouseUp) includes: condition) ifTrue: [ actWhen _ #mouseUp ]. (#(whilePressed mouseStillDown) includes: condition) ifTrue: [ actWhen _ #mouseStillDown ]. self setEventHandlers: true.! ! !ButtonProperties methodsFor: 'accessing'! actionSelector ^ actionSelector ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 08:46'! actionSelector: aSymbolOrString aSymbolOrString isEmptyOrNil ifTrue: [^actionSelector _ nil]. aSymbolOrString = 'nil' ifTrue: [^actionSelector _ nil]. actionSelector _ aSymbolOrString asSymbol. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:35'! addTextToButton: aStringOrText | tm existing | existing _ self currentTextMorphsInButton. existing do: [ :x | x delete]. aStringOrText ifNil: [^self]. tm _ TextMorph new contents: aStringOrText. tm fullBounds; lock; align: tm center with: visibleMorph center; setProperty: #textAddedByButtonProperties toValue: true; setToAdhereToEdge: #center. "maybe the user would like personal control here" "visibleMorph extent: (tm extent * 1.5) rounded." visibleMorph addMorphFront: tm. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 07:35'! adjustPositionsAfterSizeChange "re-center label, etc??"! ! !ButtonProperties methodsFor: 'accessing'! arguments ^ arguments ! ! !ButtonProperties methodsFor: 'accessing'! arguments: aCollection arguments _ aCollection asArray copy. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:40'! bringUpToDate self establishEtoyLabelWording ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:18'! currentLook ^currentLook ifNil: [currentLook _ #normal]! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:18'! currentTextInButton | existing | existing _ self currentTextMorphsInButton. existing isEmpty ifTrue: [^nil]. ^existing first ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:17'! currentTextMorphsInButton ^visibleMorph submorphsSatisfying: [ :x | x hasProperty: #textAddedByButtonProperties ] ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/9/2001 11:47'! establishEtoyLabelWording "Set the label wording, unless it has already been manually edited" | itsName | self isTileScriptingElement ifFalse: [^self]. itsName _ target externalName. self addTextToButton: itsName, ' ', arguments first. visibleMorph setBalloonText: 'click to run the script "', arguments first, '" in player named "', itsName, '"'! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 19:01'! figureOutScriptSelector self halt! ! !ButtonProperties methodsFor: 'accessing' stamp: 'nk 8/29/2004 17:16'! isTileScriptingElement actionSelector == #runScript: ifFalse: [^false]. arguments isEmptyOrNil ifTrue: [^false]. ^target isPlayerLike! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'! lockAnyText self currentTextMorphsInButton do: [ :x | x lock: true].! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'! mouseDownHaloColor ^mouseDownHaloColor! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:15'! mouseDownHaloColor: x mouseDownHaloColor _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseDownHaloWidth ^mouseDownHaloWidth! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseDownHaloWidth: x mouseDownHaloWidth _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'! mouseDownLook: aFormOrMorph self setLook: #mouseDown to: aFormOrMorph ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:43'! mouseEnterLook: aFormOrMorph self setLook: #mouseEnter to: aFormOrMorph ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'! mouseOverHaloColor ^mouseOverHaloColor! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:16'! mouseOverHaloColor: x mouseOverHaloColor _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:30'! mouseOverHaloWidth ^mouseOverHaloWidth! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 16:31'! mouseOverHaloWidth: x mouseOverHaloWidth _ x! ! !ButtonProperties methodsFor: 'accessing' stamp: 'gm 2/22/2003 14:53'! privateSetLook: aSymbol to: aFormOrMorph | f | f := (aFormOrMorph isForm) ifTrue: [aFormOrMorph] ifFalse: [aFormOrMorph imageForm]. self stateCostumes at: aSymbol put: f! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:57'! setEventHandlers: enabled enabled ifTrue: [ visibleMorph on: #mouseDown send: #mouseDown: to: self. visibleMorph on: #mouseStillDown send: #mouseStillDown: to: self. visibleMorph on: #mouseUp send: #mouseUp: to: self. visibleMorph on: #mouseEnter send: #mouseEnter: to: self. visibleMorph on: #mouseLeave send: #mouseLeave: to: self. ] ifFalse: [ #(mouseDown mouseStillDown mouseUp mouseEnter mouseLeave) do: [ :sel | visibleMorph on: sel send: nil to: nil ]. ]. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/15/2001 09:14'! setLook: aSymbol to: aFormOrMorph (self stateCostumes includesKey: #normal) ifFalse: [ self privateSetLook: #normal to: visibleMorph. ]. self privateSetLook: aSymbol to: aFormOrMorph. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:30'! stateCostumes ^stateCostumes ifNil: [stateCostumes _ Dictionary new]! ! !ButtonProperties methodsFor: 'accessing'! target ^ target ! ! !ButtonProperties methodsFor: 'accessing'! target: anObject target _ anObject ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/14/2001 18:19'! unlockAnyText self currentTextMorphsInButton do: [ :x | x lock: false].! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 15:43'! visibleMorph: x visibleMorph ifNotNil: [self setEventHandlers: false]. visibleMorph _ x. visibleMorph ifNotNil: [self setEventHandlers: true]. ! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/8/2001 09:09'! wantsRolloverIndicator ^wantsRolloverIndicator ifNil: [false]! ! !ButtonProperties methodsFor: 'accessing' stamp: 'RAA 3/10/2001 13:59'! wantsRolloverIndicator: aBoolean wantsRolloverIndicator _ aBoolean. wantsRolloverIndicator ifTrue: [ self setEventHandlers: true. ].! ! !ButtonProperties methodsFor: 'copying' stamp: 'jm 7/28/97 11:52'! updateReferencesUsing: aDictionary "If the arguments array points at a morph we are copying, then point at the new copy. And also copies the array, which is important!!" super updateReferencesUsing: aDictionary. arguments _ arguments collect: [:old | aDictionary at: old ifAbsent: [old]]. ! ! !ButtonProperties methodsFor: 'copying' stamp: 'tk 1/6/1999 17:55'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. target _ deepCopier references at: target ifAbsent: [target]. arguments _ arguments collect: [:each | deepCopier references at: each ifAbsent: [each]]. ! ! !ButtonProperties methodsFor: 'copying' stamp: 'RAA 3/16/2001 08:21'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "target _ target. Weakly copied" "actionSelector _ actionSelector. a Symbol" "arguments _ arguments. All weakly copied" actWhen _ actWhen veryDeepCopyWith: deepCopier. "oldColor _ oldColor veryDeepCopyWith: deepCopier." visibleMorph _ visibleMorph. "I guess this will have been copied already if needed" delayBetweenFirings _ delayBetweenFirings. mouseDownHaloColor _ mouseDownHaloColor. stateCostumes _ stateCostumes veryDeepCopyWith: deepCopier. currentLook _ currentLook.! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:28'! addMouseOverHalo self wantsRolloverIndicator ifTrue: [ visibleMorph addMouseActionIndicatorsWidth: mouseOverHaloWidth color: mouseOverHaloColor. ]. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:29'! delayBetweenFirings ^delayBetweenFirings! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 09:55'! delayBetweenFirings: millisecondsOrNil delayBetweenFirings _ millisecondsOrNil! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/15/2001 09:21'! displayCostume: aSymbol self currentLook == aSymbol ifTrue: [^true]. self stateCostumes at: aSymbol ifPresent: [ :aForm | currentLook _ aSymbol. visibleMorph wearCostume: aForm. ^true ]. ^false ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:58'! doButtonAction self doButtonAction: nil! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 17:08'! doButtonAction: evt | arity | target ifNil: [^self]. actionSelector ifNil: [^self]. arguments ifNil: [arguments _ #()]. Cursor normal showWhile: [ arity _ actionSelector numArgs. arity = arguments size ifTrue: [ target perform: actionSelector withArguments: arguments ]. arity = (arguments size + 1) ifTrue: [ target perform: actionSelector withArguments: {evt},arguments ]. arity = (arguments size + 2) ifTrue: [ target perform: actionSelector withArguments: {evt. visibleMorph},arguments ]. ]! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 19:01'! editButtonsScript: evt "The user has touched my Scriptor halo-handle. Bring up a Scriptor on the script of the button." | cardsPasteUp cardsPlayer anEditor scriptSelector | cardsPasteUp _ self pasteUpMorph. (cardsPlayer _ cardsPasteUp assuredPlayer) assureUniClass. scriptSelector _ self figureOutScriptSelector. scriptSelector ifNil: [ scriptSelector _ cardsPasteUp scriptSelectorToTriggerFor: self. anEditor _ cardsPlayer newTextualScriptorFor: scriptSelector. evt hand attachMorph: anEditor. ^self ]. (cardsPlayer class selectors includes: scriptSelector) ifTrue: [ anEditor _ cardsPlayer scriptEditorFor: scriptSelector. evt hand attachMorph: anEditor. ^self ]. "Method somehow got removed; I guess we start aftresh" scriptSelector _ nil. ^ self editButtonsScript! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:40'! mouseDown: evt self displayCostume: #mouseDown. mouseDownTime _ Time millisecondClockValue. nextTimeToFire _ nil. delayBetweenFirings ifNotNil: [ nextTimeToFire _ mouseDownTime + delayBetweenFirings. ]. self wantsRolloverIndicator ifTrue: [ visibleMorph addMouseActionIndicatorsWidth: mouseDownHaloWidth color: mouseDownHaloColor. ]. actWhen == #mouseDown ifFalse: [^self]. (visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self]. self doButtonAction: evt. "===== aMorph . now _ Time millisecondClockValue. oldColor _ color. actWhen == #buttonDown ifTrue: [self doButtonAction] ifFalse: [ self updateVisualState: evt; refreshWorld]. dt _ Time millisecondClockValue - now max: 0. dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]. self mouseStillDown: evt. ====="! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'! mouseEnter: evt self displayCostume: #mouseEnter. self addMouseOverHalo. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/14/2001 18:39'! mouseLeave: evt self displayCostume: #normal. visibleMorph deleteAnyMouseActionIndicators. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/8/2001 07:57'! mouseMove: evt actWhen == #mouseDown ifTrue: [^ self]. self updateVisualState: evt.! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 08:57'! mouseStillDown: evt (visibleMorph containsPoint: evt cursorPoint) ifFalse: [^self]. nextTimeToFire ifNil: [^self]. nextTimeToFire <= Time millisecondClockValue ifTrue: [ self doButtonAction: evt. nextTimeToFire _ Time millisecondClockValue + self delayBetweenFirings. ^self ]. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/16/2001 08:29'! mouseUp: evt (self displayCostume: #mouseEnter) ifFalse: [self displayCostume: #normal]. self addMouseOverHalo. ! ! !ButtonProperties methodsFor: 'events' stamp: 'RAA 3/9/2001 12:27'! replaceVisibleMorph: aNewMorph | old oldOwner oldText | old _ visibleMorph. oldText _ self currentTextInButton. self visibleMorph: nil. old buttonProperties: nil. aNewMorph buttonProperties: self. self visibleMorph: aNewMorph. self addTextToButton: oldText. oldOwner _ old owner ifNil: [^self]. oldOwner replaceSubmorph: old by: aNewMorph.! ! !ButtonProperties methodsFor: 'initialization' stamp: 'ar 3/17/2001 20:12'! adaptToWorld: aWorld super adaptToWorld: aWorld. target _ target adaptedToWorld: aWorld.! ! !ButtonProperties methodsFor: 'initialization' stamp: 'RAA 3/9/2001 09:47'! initialize wantsRolloverIndicator _ false. delayBetweenFirings _ nil. mouseOverHaloWidth _ 10. mouseOverHaloColor _ Color blue alpha: 0.3. mouseDownHaloWidth _ 15. mouseDownHaloColor _ Color blue alpha: 0.7. arguments _ #().! ! !ButtonProperties methodsFor: 'menu' stamp: 'yo 3/16/2005 20:58'! setActWhen | selections | selections _ #(mouseDown mouseUp mouseStillDown). actWhen _ (SelectionMenu labels: (selections collect: [:t | t translated]) selections: selections) startUpWithCaption: 'Choose one of the following conditions' translated ! ! !ButtonProperties methodsFor: 'menu' stamp: 'yo 3/16/2005 20:53'! setActionSelector | newSel | newSel _ FillInTheBlank request: 'Please type the selector to be sent to the target when this button is pressed' translated initialAnswer: actionSelector. newSel isEmpty ifFalse: [self actionSelector: newSel]. ! ! !ButtonProperties methodsFor: 'menu' stamp: 'yo 3/14/2005 13:07'! setArguments | s newArgs newArgsArray | s _ WriteStream on: ''. arguments do: [:arg | arg printOn: s. s nextPutAll: '. ']. newArgs _ FillInTheBlank request: 'Please type the arguments to be sent to the target when this button is pressed separated by periods' translated initialAnswer: s contents. newArgs isEmpty ifFalse: [ newArgsArray _ Compiler evaluate: '{', newArgs, '}' for: self logged: false. self arguments: newArgsArray]. ! ! !ButtonProperties methodsFor: 'menu'! setLabel | newLabel | newLabel _ FillInTheBlank request: 'Please a new label for this button' initialAnswer: self label. newLabel isEmpty ifFalse: [self label: newLabel]. ! ! !ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageSound: event ^ target menuPageSoundFor: self event: event! ! !ButtonProperties methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageVisual: event ^ target menuPageVisualFor: self event: event! ! !ButtonProperties methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:52'! setTarget: evt | rootMorphs | rootMorphs := self world rootMorphsAt: evt hand targetOffset. target := rootMorphs size > 1 ifTrue: [rootMorphs second] ifFalse: [nil]! ! !ButtonProperties methodsFor: 'visual properties' stamp: 'RAA 3/8/2001 14:24'! updateVisualState: evt " oldColor ifNil: [^self]. self color: ((self containsPoint: evt cursorPoint) ifTrue: [oldColor mixed: 1/2 with: Color white] ifFalse: [oldColor])"! ! !ButtonProperties commentStamp: '' prior: 0! ButtonProperties test1 ButtonProperties test2 ButtonProperties test3 ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:29'! ellipticalButtonWithText: aStringOrText | m prop | m _ EllipseMorph new. prop _ m ensuredButtonProperties. prop target: #(1 2 3); actionSelector: #inspect; actWhen: #mouseUp; addTextToButton: aStringOrText; wantsRolloverIndicator: true. ^m! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:31'! test1 | m prop | m _ EllipseMorph new. prop _ m ensuredButtonProperties. prop target: #(1 2 3); actionSelector: #inspect; actWhen: #mouseUp. m openInWorld.! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 08:41'! test2 (self ellipticalButtonWithText: 'Hello world') openInWorld.! ! !ButtonProperties class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! test3 | m | (m _ self ellipticalButtonWithText: 'Hello world') openInWorld. m ensuredButtonProperties target: Beeper; actionSelector: #beep; delayBetweenFirings: 1000.! ! !ButtonProperties class methodsFor: 'printing' stamp: 'sw 2/16/98 01:31'! defaultNameStemForInstances ^ 'button'! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:25'! acceptDroppingMorph: aMorph event: evt in: aSubmorph | why | self clearDropHighlightingEvt: evt morph: aSubmorph. why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. why == #changeTargetMorph ifTrue: [ self targetProperties replaceVisibleMorph: aMorph. myTarget _ aMorph. self rebuild. ^true ]. why == #changeTargetTarget ifTrue: [ (aMorph setAsActionInButtonProperties: self targetProperties) ifFalse: [ ^false ]. ^true ]. why == #changeTargetMouseDownLook ifTrue: [ self targetProperties mouseDownLook: aMorph. ^false ]. why == #changeTargetMouseEnterLook ifTrue: [ self targetProperties mouseEnterLook: aMorph. ^false ]. ^false ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:45'! addTextToTarget self targetProperties currentTextInButton ifNil: [ self targetProperties addTextToButton: '???'. ]. self targetProperties currentTextInButton openATextPropertySheet. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'! adjustTargetMouseDownHaloSize: aFractionalPoint self targetProperties mouseDownHaloWidth: ((aFractionalPoint x * 10) rounded max: 0). ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:08'! adjustTargetMouseOverHaloSize: aFractionalPoint self targetProperties mouseOverHaloWidth: ((aFractionalPoint x * 10) rounded max: 0). ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:14'! adjustTargetRepeatingInterval: aFractionalPoint | n | n _ 2 raisedTo: ((aFractionalPoint x * 12) rounded max: 1). self targetProperties delayBetweenFirings: n. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:26'! allowDropsInto: aMorph withIntent: aSymbol aMorph on: #mouseEnterDragging send: #mouseEnterDraggingEvt:morph: to: self; on: #mouseLeaveDragging send: #mouseLeaveDraggingEvt:morph: to: self; on: #mouseLeave send: #clearDropHighlightingEvt:morph: to: self; setProperty: #handlerForDrops toValue: self; setProperty: #intentOfDroppedMorphs toValue: aSymbol; borderWidth: 1; borderColor: Color gray ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:03'! attachMorphOfClass: aClass to: aHand aHand attachMorph: aClass new! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'! clearDropHighlightingEvt: evt morph: aMorph aMorph color: Color transparent. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:25'! doEnables | itsName | self allMorphsDo: [ :each | itsName _ each knownName. itsName == #pickerForMouseDownColor ifTrue: [ self enable: each when: self targetWantsRollover ]. itsName == #pickerForMouseOverColor ifTrue: [ self enable: each when: self targetWantsRollover ]. itsName == #paneForRepeatingInterval ifTrue: [ self enable: each when: self targetRepeatingWhileDown ]. ]. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/10/2001 13:36'! doRemoveProperties myTarget buttonProperties: nil. self delete.! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:00'! mouseDownEvent: evt for: aSubmorph | why aMenu | why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. why == #changeTargetMorph ifTrue: [ aMenu _ MenuMorph new defaultTarget: self. { {'Rectangle'. RectangleMorph}. {'Ellipse'. EllipseMorph} } do: [ :pair | aMenu add: pair first translated target: self selector: #attachMorphOfClass:to: argumentList: {pair second. evt hand}. ]. aMenu popUpEvent: evt in: self world. ^self ]. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:33'! mouseEnterDraggingEvt: evt morph: aMorph aMorph color: (Color red alpha: 0.5)! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/16/2001 08:24'! mouseLeaveDraggingEvt: evt morph: aMorph self clearDropHighlightingEvt: evt morph: aMorph. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForActsOnMouseDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseDown setter: #toggleTargetActsOnMouseDown help: 'If the button is to act when the mouse goes down' translated. self lockedString: ' Mouse-down action' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForActsOnMouseUpToggle ^self inARow: { self directToggleButtonFor: self getter: #targetActsOnMouseUp setter: #toggleTargetActsOnMouseUp help: 'If the button is to act when the mouse goes up' translated. self lockedString: ' Mouse-up action' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForButtonSelectorReport ^self inARow: { self lockedString: 'Action: ' translated. UpdatingStringMorph new useStringFormat; getSelector: #actionSelector; target: self targetProperties; growable: true; minimumWidth: 24; lock. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForButtonTargetReport | r | r _ self inARow: { self lockedString: 'Target: ' translated. UpdatingStringMorph new useStringFormat; getSelector: #target; target: self targetProperties; growable: true; minimumWidth: 24; lock. }. r hResizing: #shrinkWrap. self allowDropsInto: r withIntent: #changeTargetTarget. r setBalloonText: 'Drop another morph here to change the target and action of this button. (Only some morphs will work)' translated. ^self inARow: {r} ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForChangeMouseDownLook | r | r _ self inARow: { self lockedString: ' Mouse-down look ' translated. }. self allowDropsInto: r withIntent: #changeTargetMouseDownLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse is clicked in it.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForChangeMouseEnterLook | r | r _ self inARow: { self lockedString: ' Mouse-enter look ' translated. }. self allowDropsInto: r withIntent: #changeTargetMouseEnterLook. r setBalloonText: 'Drop another morph here to change the visual appearance of this button when the mouse enters it.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForChangeVisibleMorph | r | r _ self inARow: { self lockedString: ' Change morph ' translated. }. r on: #mouseDown send: #mouseDownEvent:for: to: self. self allowDropsInto: r withIntent: #changeTargetMorph. r setBalloonText: 'Drop another morph here to change the visual appearance of this button. Or click here to get a menu of possible replacement morphs.' translated. ^r ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForMouseDownColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseDownHaloColor setter: #mouseDownHaloColor:. self lockedString: 'mouse-down halo color' translated. self paneForMouseDownHaloWidth. } named: #pickerForMouseDownColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:01'! paneForMouseDownHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseDownHaloWidth selector: #adjustTargetMouseDownHaloSize: help: 'Drag in here to change the halo width' translated }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02'! paneForMouseOverColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self targetProperties getter: #mouseOverHaloColor setter: #mouseOverHaloColor:. self lockedString: 'mouse-over halo color' translated. self paneForMouseOverHaloWidth. } named: #pickerForMouseOverColor) layoutInset: 0. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02'! paneForMouseOverHaloWidth ^(self inARow: { self buildFakeSlider: #valueForMouseOverHaloWidth selector: #adjustTargetMouseOverHaloSize: help: 'Drag in here to change the halo width' translated }) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02'! paneForRepeatingInterval ^(self inAColumn: { self buildFakeSlider: #valueForRepeatingInterval selector: #adjustTargetRepeatingInterval: help: 'Drag in here to change how often the button repeats while the mouse is down' translated } named: #paneForRepeatingInterval ) hResizing: #shrinkWrap ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02'! paneForWantsFiringWhileDownToggle ^self inARow: { self directToggleButtonFor: self getter: #targetRepeatingWhileDown setter: #toggleTargetRepeatingWhileDown help: 'Turn repeating while mouse is held down on or off' translated. self lockedString: ' Mouse-down repeating ' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:02'! paneForWantsRolloverToggle ^self inARow: { self directToggleButtonFor: self getter: #targetWantsRollover setter: #toggleTargetWantsRollover help: 'Turn mouse-over highlighting on or off' translated. self lockedString: ' Mouse-over highlighting' translated. } ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:03'! rebuild | buttonColor | myTarget ensuredButtonProperties. "self targetProperties unlockAnyText." "makes styling the text easier" self removeAllMorphs. self addAColumn: { self lockedString: ('Button Properties for {1}' translated format: {myTarget name}). }. self addAColumn: { self paneForButtonTargetReport. }. self addAColumn: { self paneForButtonSelectorReport. }. self addAColumn: { (self inARow: { self paneForActsOnMouseDownToggle. self paneForActsOnMouseUpToggle. }) hResizing: #shrinkWrap. }. self addAColumn: { self inARow: { (self paneForWantsFiringWhileDownToggle) hResizing: #shrinkWrap. self paneForRepeatingInterval. }. }. self addAColumn: { (self inAColumn: { self paneForWantsRolloverToggle. }) hResizing: #shrinkWrap. }. self addARow: { self paneForMouseOverColorPicker. self paneForMouseDownColorPicker. }. self addARow: { self paneForChangeMouseEnterLook. self paneForChangeMouseDownLook. }. buttonColor _ color lighter. self addARow: { self inAColumn: { self addARow: { self buttonNamed: 'Add label' translated action: #addTextToTarget color: buttonColor help: 'add some text to the button' translated. self buttonNamed: 'Remove label' translated action: #removeTextFromTarget color: buttonColor help: 'remove text from the button' translated. }. self addARow: { self buttonNamed: 'Accept' translated action: #doAccept color: buttonColor help: 'keep changes made and close panel' translated. self buttonNamed: 'Cancel' translated action: #doCancel color: buttonColor help: 'cancel changes made and close panel' translated. self transparentSpacerOfSize: 10@3. self buttonNamed: 'Main' translated action: #doMainProperties color: color lighter help: 'open a main properties panel for the morph' translated. self buttonNamed: 'Remove' translated action: #doRemoveProperties color: color lighter help: 'remove the button properties of this morph' translated. }. }. self inAColumn: { self paneForChangeVisibleMorph }. }. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:36'! removeTextFromTarget self targetProperties addTextToButton: nil. ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'! targetActsOnMouseDown ^self targetProperties actWhen == #mouseDown! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:49'! targetActsOnMouseUp ^self targetProperties actWhen == #mouseUp! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:05'! targetProperties ^myTarget ensuredButtonProperties! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:01'! targetRepeatingWhileDown ^self targetProperties delayBetweenFirings notNil! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'! targetWantsRollover ^self targetProperties wantsRolloverIndicator! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:51'! toggleTargetActsOnMouseDown | prop | prop _ self targetProperties. prop actWhen: (prop actWhen == #mouseDown ifTrue: [nil] ifFalse: [#mouseDown])! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:50'! toggleTargetActsOnMouseUp | prop | prop _ self targetProperties. prop actWhen: (prop actWhen == #mouseUp ifTrue: [nil] ifFalse: [#mouseUp])! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 17:02'! toggleTargetRepeatingWhileDown | prop | prop _ self targetProperties. prop delayBetweenFirings: (prop delayBetweenFirings ifNil: [1024] ifNotNil: [nil]) ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:28'! toggleTargetWantsRollover self targetProperties wantsRolloverIndicator: self targetProperties wantsRolloverIndicator not! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'yo 1/14/2005 19:52'! valueForMouseDownHaloWidth ^ 'mouse-down halo width: ' translated, self targetProperties mouseDownHaloWidth printString ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'yo 1/14/2005 19:53'! valueForMouseOverHaloWidth ^ 'mouse-over halo width: ' translated, self targetProperties mouseOverHaloWidth printString ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 22:04'! valueForRepeatingInterval | n s | n _ self targetProperties delayBetweenFirings. s _ n ifNil: [ '*none*' ] ifNotNil: [ n < 1000 ifTrue: [n printString,' ms'] ifFalse: [(n // 1000) printString,' secs'] ]. ^'interval: ' translated, s ! ! !ButtonPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:31'! wantsDroppedMorph: aMorph event: evt in: aSubmorph | why | why _ aSubmorph valueOfProperty: #intentOfDroppedMorphs. ^why notNil " toValue: #changeTargetMorph. ^true"! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self defaultColor darker! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.935 g: 0.839 b: 0.452! ! !ButtonPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:17'! initialize "initialize the state of the receiver" super initialize. "" myTarget ifNil: [myTarget _ RectangleMorph new openInWorld]. thingsToRevert at: #buttonProperties: put: myTarget buttonProperties. self rebuild! ! !ButtonPropertiesMorph commentStamp: '' prior: 0! ButtonPropertiesMorph basicNew targetMorph: self; initialize; openNearTarget! !ByteArray methodsFor: 'accessing' stamp: 'yo 10/23/2002 23:35'! asMultiString ^ MultiString fromByteArray: self. ! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 8/2/2003 19:29'! longAt: index put: value bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 b3 | b0 _ value bitShift: -24. b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80). b0 < 0 ifTrue:[b0 := 256 + b0]. b1 _ (value bitShift: -16) bitAnd: 255. b2 _ (value bitShift: -8) bitAnd: 255. b3 _ value bitAnd: 255. aBool ifTrue:[ self at: index put: b0. self at: index+1 put: b1. self at: index+2 put: b2. self at: index+3 put: b3. ] ifFalse:[ self at: index put: b3. self at: index+1 put: b2. self at: index+2 put: b1. self at: index+3 put: b0. ]. ^value! ! !ByteArray methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! hash "#hash is implemented, because #= is implemented" ^self class hashBytes: self startingWith: self species hash! ! !ByteArray methodsFor: 'zip archive' stamp: 'nk 8/21/2004 15:23'! lastIndexOfPKSignature: aSignature "Answer the last index in me where aSignature (4 bytes long) occurs, or 0 if not found" | a b c d | a _ aSignature first. b _ aSignature second. c _ aSignature third. d _ aSignature fourth. (self size - 3) to: 1 by: -1 do: [ :i | (((self at: i) = a) and: [ ((self at: i + 1) = b) and: [ ((self at: i + 2) = c) and: [ ((self at: i + 3) = d) ]]]) ifTrue: [ ^i ] ]. ^0! ! !ByteArray class methodsFor: 'byte based hash' stamp: 'SqR 8/21/2002 16:21'! hashBytes: aByteArray startingWith: speciesHash "Answer the hash of a byte-indexed collection, using speciesHash as the initial value. See SmallInteger>>hashMultiply. The primitive should be renamed at a suitable point in the future" | byteArraySize hash low | self var: #aHash declareC: 'int speciesHash'. self var: #aByteArray declareC: 'unsigned char *aByteArray'. byteArraySize _ aByteArray size. hash _ speciesHash bitAnd: 16rFFFFFFF. 1 to: byteArraySize do: [:pos | hash _ hash + (aByteArray basicAt: pos). "Begin hashMultiply" low _ hash bitAnd: 16383. hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. ]. ^ hash! ! !ByteArrayBugz methodsFor: 'as yet unclassified' stamp: 'ar 8/2/2003 19:28'! testByteArrayLongAt | ba value | ba := ByteArray new: 4. value := -1. self shouldnt:[ba longAt: 1 put: value bigEndian: true] raise: Error. self assert: (ba longAt: 1 bigEndian: true) = value. self shouldnt:[ba longAt: 1 put: value bigEndian: false] raise: Error. self assert: (ba longAt: 1 bigEndian: false) = value. ! ! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:01'! nextPut: encodedObject "pass through for stream compatibility" ^target nextPut: encodedObject. ! ! !ByteEncoder methodsFor: 'writing' stamp: 'nk 12/31/2003 16:00'! nextPutAll: encodedObject "pass through for stream compatibility" ^target nextPutAll: encodedObject. ! ! !CNGBTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ SimplifiedChineseEnvironment. ! ! !CNGBTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 14:42'! leadingChar ^ GB2312 leadingChar ! ! !CNGBTextConverter commentStamp: '' prior: 0! Text converter for Simplified Chinese variation of EUC. (Even though the name doesn't look so, it is what it is.)! !CNGBTextConverter class methodsFor: 'utilities' stamp: 'yo 10/23/2002 14:42'! encodingNames ^ #('gb2312' ) copy ! ! !CP1250ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/19/2005 20:26'! fromSystemClipboard: aString | result converter | result := WriteStream on: (String new: aString size). converter := CP1250TextConverter new. aString do: [:each | result nextPut: (converter toSqueak: each squeakToIso) asCharacter. ]. ^ result contents. ! ! !CP1250ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/19/2005 15:13'! toSystemClipboard: aString | result converter r | aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization" result _ WriteStream on: (String new: aString size). converter _ CP1250TextConverter new. aString do: [:each | r _ converter fromSqueak: each. r charCode < 255 ifTrue: [ result nextPut: r isoToSqueak]]. ^ result contents. ! ! !CP1250InputInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/19/2005 20:40'! initialize converter _ CP1250TextConverter new. ! ! !CP1250InputInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/19/2005 20:31'! nextCharFrom: sensor firstEvt: evtBuf "Input from the Czech keyboard under Windows doesn't correspond to cp-1250 or iso-8859-2 encoding!!" | keyValue | keyValue := evtBuf third. ^ converter toSqueak: keyValue asCharacter squeakToIso. ! ! !CP1250TextConverter methodsFor: 'conversion' stamp: 'pk 1/19/2005 14:34'! nextFromStream: aStream | character1 | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. ^ self toSqueak: character1. ! ! !CP1250TextConverter methodsFor: 'conversion' stamp: 'pk 1/19/2005 14:34'! nextPut: aCharacter toStream: aStream aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ aStream basicNextPut: aCharacter charCode. ^ aStream. ]. aCharacter class == MultiCharacter ifTrue: [ aStream nextInt32Put: aCharacter charCode. ^ aStream. ]. ]. aCharacter charCode < 128 ifTrue: [ aStream basicNextPut: aCharacter. ] ifFalse: [ aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)). ]. ! ! !CP1250TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'! fromSqueak: char ^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! ! !CP1250TextConverter methodsFor: 'private' stamp: 'pk 1/19/2005 18:05'! toSqueak: char | value | value _ char charCode. value < 129 ifTrue: [^ char]. value > 255 ifTrue: [^ char]. ^ MultiCharacter leadingChar: Latin2Environment leadingChar code: (#( 16r0081 16r201A 16r0083 16r201E 16r2026 16r2020 16r2021 16r0088 16r2030 16r0160 16r2039 16r015A 16r0164 16r017D 16r0179 16r0090 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 16r0098 16r2122 16r0161 16r203A 16r015B 16r0165 16r017E 16r017A 16r00A0 16r02C7 16r02D8 16r0141 16r00A4 16r0104 16r00A6 16r00A7 16r00A8 16r00A9 16r015E 16r00AB 16r00AC 16r00AD 16r00AE 16r017B 16r00B0 16r00B1 16r02DB 16r0142 16r00B4 16r00B5 16r00B6 16r00B7 16r00B8 16r0105 16r015F 16r00BB 16r013D 16r02DD 16r013E 16r017C 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 ) at: (value - 129 + 1)). ! ! !CP1250TextConverter commentStamp: '' prior: 0! Text converter for CP1250. Windows code page used in Eastern Europe.! !CP1250TextConverter class methodsFor: 'class initialization' stamp: 'pk 1/19/2005 19:35'! initialize " CP1250TextConverter initialize " FromTable _ Dictionary new. FromTable at: 16r0081 put: 16r81. FromTable at: 16r201A put: 16r82. FromTable at: 16r0083 put: 16r83. FromTable at: 16r201E put: 16r84. FromTable at: 16r2026 put: 16r85. FromTable at: 16r2020 put: 16r86. FromTable at: 16r2021 put: 16r87. FromTable at: 16r0088 put: 16r88. FromTable at: 16r2030 put: 16r89. FromTable at: 16r0160 put: 16r8A. FromTable at: 16r2039 put: 16r8B. FromTable at: 16r015A put: 16r8C. FromTable at: 16r0164 put: 16r8D. FromTable at: 16r017D put: 16r8E. FromTable at: 16r0179 put: 16r8F. FromTable at: 16r0090 put: 16r90. FromTable at: 16r2018 put: 16r91. FromTable at: 16r2019 put: 16r92. FromTable at: 16r201C put: 16r93. FromTable at: 16r201D put: 16r94. FromTable at: 16r2022 put: 16r95. FromTable at: 16r2013 put: 16r96. FromTable at: 16r2014 put: 16r97. FromTable at: 16r0098 put: 16r98. FromTable at: 16r2122 put: 16r99. FromTable at: 16r0161 put: 16r9A. FromTable at: 16r203A put: 16r9B. FromTable at: 16r015B put: 16r9C. FromTable at: 16r0165 put: 16r9D. FromTable at: 16r017E put: 16r9E. FromTable at: 16r017A put: 16r9F. FromTable at: 16r00A0 put: 16rA0. FromTable at: 16r02C7 put: 16rA1. FromTable at: 16r02D8 put: 16rA2. FromTable at: 16r0141 put: 16rA3. FromTable at: 16r00A4 put: 16rA4. FromTable at: 16r0104 put: 16rA5. FromTable at: 16r00A6 put: 16rA6. FromTable at: 16r00A7 put: 16rA7. FromTable at: 16r00A8 put: 16rA8. FromTable at: 16r00A9 put: 16rA9. FromTable at: 16r015E put: 16rAA. FromTable at: 16r00AB put: 16rAB. FromTable at: 16r00AC put: 16rAC. FromTable at: 16r00AD put: 16rAD. FromTable at: 16r00AE put: 16rAE. FromTable at: 16r017B put: 16rAF. FromTable at: 16r00B0 put: 16rB0. FromTable at: 16r00B1 put: 16rB1. FromTable at: 16r02DB put: 16rB2. FromTable at: 16r0142 put: 16rB3. FromTable at: 16r00B4 put: 16rB4. FromTable at: 16r00B5 put: 16rB5. FromTable at: 16r00B6 put: 16rB6. FromTable at: 16r00B7 put: 16rB7. FromTable at: 16r00B8 put: 16rB8. FromTable at: 16r0105 put: 16rB9. FromTable at: 16r015F put: 16rBA. FromTable at: 16r00BB put: 16rBB. FromTable at: 16r013D put: 16rBC. FromTable at: 16r02DD put: 16rBD. FromTable at: 16r013E put: 16rBE. FromTable at: 16r017C put: 16rBF. FromTable at: 16r0154 put: 16rC0. FromTable at: 16r00C1 put: 16rC1. FromTable at: 16r00C2 put: 16rC2. FromTable at: 16r0102 put: 16rC3. FromTable at: 16r00C4 put: 16rC4. FromTable at: 16r0139 put: 16rC5. FromTable at: 16r0106 put: 16rC6. FromTable at: 16r00C7 put: 16rC7. FromTable at: 16r010C put: 16rC8. FromTable at: 16r00C9 put: 16rC9. FromTable at: 16r0118 put: 16rCA. FromTable at: 16r00CB put: 16rCB. FromTable at: 16r011A put: 16rCC. FromTable at: 16r00CD put: 16rCD. FromTable at: 16r00CE put: 16rCE. FromTable at: 16r010E put: 16rCF. FromTable at: 16r0110 put: 16rD0. FromTable at: 16r0143 put: 16rD1. FromTable at: 16r0147 put: 16rD2. FromTable at: 16r00D3 put: 16rD3. FromTable at: 16r00D4 put: 16rD4. FromTable at: 16r0150 put: 16rD5. FromTable at: 16r00D6 put: 16rD6. FromTable at: 16r00D7 put: 16rD7. FromTable at: 16r0158 put: 16rD8. FromTable at: 16r016E put: 16rD9. FromTable at: 16r00DA put: 16rDA. FromTable at: 16r0170 put: 16rDB. FromTable at: 16r00DC put: 16rDC. FromTable at: 16r00DD put: 16rDD. FromTable at: 16r0162 put: 16rDE. FromTable at: 16r00DF put: 16rDF. FromTable at: 16r0155 put: 16rE0. FromTable at: 16r00E1 put: 16rE1. FromTable at: 16r00E2 put: 16rE2. FromTable at: 16r0103 put: 16rE3. FromTable at: 16r00E4 put: 16rE4. FromTable at: 16r013A put: 16rE5. FromTable at: 16r0107 put: 16rE6. FromTable at: 16r00E7 put: 16rE7. FromTable at: 16r010D put: 16rE8. FromTable at: 16r00E9 put: 16rE9. FromTable at: 16r0119 put: 16rEA. FromTable at: 16r00EB put: 16rEB. FromTable at: 16r011B put: 16rEC. FromTable at: 16r00ED put: 16rED. FromTable at: 16r00EE put: 16rEE. FromTable at: 16r010F put: 16rEF. FromTable at: 16r0111 put: 16rF0. FromTable at: 16r0144 put: 16rF1. FromTable at: 16r0148 put: 16rF2. FromTable at: 16r00F3 put: 16rF3. FromTable at: 16r00F4 put: 16rF4. FromTable at: 16r0151 put: 16rF5. FromTable at: 16r00F6 put: 16rF6. FromTable at: 16r00F7 put: 16rF7. FromTable at: 16r0159 put: 16rF8. FromTable at: 16r016F put: 16rF9. FromTable at: 16r00FA put: 16rFA. FromTable at: 16r0171 put: 16rFB. FromTable at: 16r00FC put: 16rFC. FromTable at: 16r00FD put: 16rFD. FromTable at: 16r0163 put: 16rFE. FromTable at: 16r02D9 put: 16rFF! ! !CP1250TextConverter class methodsFor: 'utilities' stamp: 'pk 1/19/2005 14:35'! encodingNames ^ #('cp-1250') copy ! ! !CP1253TextConverter methodsFor: 'conversion' stamp: 'yo 2/19/2004 10:12'! nextFromStream: aStream | character1 | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. ^ self toSqueak: character1. ! ! !CP1253TextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:39'! toSqueak: char | value | value _ char charCode. value < 128 ifTrue: [^ char]. value > 255 ifTrue: [^ char]. ^ MultiCharacter leadingChar: GreekEnvironment leadingChar code: (#( 16r20AC 16rFFFD 16r201A 16r0192 16r201E 16r2026 16r2020 16r2021 16rFFFD 16r2030 16rFFFD 16r2039 16rFFFD 16rFFFD 16rFFFD 16rFFFD 16rFFFD 16r2018 16r2019 16r201C 16r201D 16r2022 16r2013 16r2014 16rFFFD 16r2122 16rFFFD 16r203A 16rFFFD 16rFFFD 16rFFFD 16rFFFD 16r00A0 16r0385 16r0386 16r00A3 16r00A4 16r00A5 16r00A6 16r00A7 16r00A8 16r00A9 16rFFFD 16r00AB 16r00AC 16r00AD 16r00AE 16r2015 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r00B5 16r00B6 16r00B7 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16rFFFD ) at: (value - 128 + 1)). ! ! !CP1253TextConverter commentStamp: '' prior: 0! Text converter for CP1253. Windows code page used for Greek.! !CP1253TextConverter class methodsFor: 'utilities' stamp: 'yo 2/19/2004 10:11'! encodingNames ^ #('cp-1253') copy ! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:13'! debugProcess: aProcess | uiPriority oldPriority | uiPriority _ Processor activeProcess priority. aProcess priority >= uiPriority ifTrue: [ oldPriority _ ProcessBrowser setProcess: aProcess toPriority: uiPriority - 1 ]. ProcessBrowser debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:27'! debugProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:21'! resumeProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. ProcessBrowser resumeProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'nk 3/8/2001 17:24'! terminateProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. ProcessBrowser terminateProcess: aProcess.! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 20:47'! catchThePig: aProcess | rules | "nickname, allow-stop, allow-debug" rules _ ProcessBrowser nameAndRulesFor: aProcess. (ProcessBrowser isUIProcess: aProcess) ifTrue: [ "aProcess debugWithTitle: 'Interrupted from the CPUWatcher'." ] ifFalse: [ rules second ifFalse: [ ^self ]. ProcessBrowser suspendProcess: aProcess. self openWindowForSuspendedProcess: aProcess ] ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 16:05'! findThePig "tally has been updated. Look at it to see if there is a bad process. This runs at a very high priority, so make it fast" | countAndProcess | countAndProcess _ tally sortedCounts first. (countAndProcess key / tally size > self threshold) ifTrue: [ | proc | proc _ countAndProcess value. proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK" self catchThePig: proc ]. ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:34'! openMVCWindowForSuspendedProcess: aProcess ProcessBrowser new openAsMVC.! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 17:23'! openMorphicWindowForSuspendedProcess: aProcess | menu rules | menu _ MenuMorph new. "nickname allow-stop allow-debug" rules _ ProcessBrowser nameAndRulesFor: aProcess. menu add: 'Dismiss this menu' target: menu selector: #delete; addLine. menu add: 'Open Process Browser' target: ProcessBrowser selector: #open. menu add: 'Resume' target: self selector: #resumeProcess:fromMenu: argumentList: { aProcess . menu }. menu add: 'Terminate' target: self selector: #terminateProcess:fromMenu: argumentList: { aProcess . menu }. rules third ifTrue: [ menu add: 'Debug at a lower priority' target: self selector: #debugProcess:fromMenu: argumentList: { aProcess . menu }. ]. menu addTitle: aProcess identityHash asString, ' ', rules first, ' is taking too much time and has been suspended. What do you want to do with it?'. menu stayUp: true. menu popUpInWorld ! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'nk 3/8/2001 18:35'! openWindowForSuspendedProcess: aProcess Smalltalk isMorphic ifTrue: [ WorldState addDeferredUIMessage: [ self openMorphicWindowForSuspendedProcess: aProcess ] ] ifFalse: [ [ self openMVCWindowForSuspendedProcess: aProcess ] forkAt: Processor userSchedulingPriority ] ! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:39'! monitorProcessPeriod: secs sampleRate: msecs self stopMonitoring. watcher _ [ [ | promise | promise _ Processor tallyCPUUsageFor: secs every: msecs. tally _ promise value. promise _ nil. self findThePig. ] repeat ] forkAt: Processor highestPriority. Processor yield ! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'! startMonitoring self monitorProcessPeriod: 20 sampleRate: 100! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'nk 3/8/2001 16:24'! stopMonitoring watcher ifNotNil: [ ProcessBrowser terminateProcess: watcher. watcher _ nil. ]! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 07:56'! isMonitoring ^watcher notNil! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'! tally ^tally copy! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:49'! threshold "What fraction of the time can a process be the active process before we stop it?" ^threshold! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:38'! threshold: thresh "What fraction of the time can a process be the active process before we stop it?" threshold _ (thresh max: 0.02) min: 1.0! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/14/2001 08:26'! watcherProcess ^watcher! ! !CPUWatcher commentStamp: '' prior: 0! CPUWatcher implements a simple runaway process monitoring tool that will suspend a process that is taking up too much of Squeak's time and allow user interaction. By default it watches for a Process that is taking more than 80% of the time; this threshold can be changed. CPUWatcher can also be used to show cpu percentages for each process from within the ProcessBrowser. CPUWatcher startMonitoring. "process period 20 seconds, sample rate 100 msec" CPUWatcher current monitorProcessPeriod: 10 sampleRate: 20. CPUWatcher current threshold: 0.5. "change from 80% to 50%" CPUWatcher stopMonitoring. ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 18:45'! current ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'! currentWatcherProcess ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 21:43'! dumpTallyOnTranscript self current ifNotNil: [ ProcessBrowser dumpTallyOnTranscript: self current tally ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:15'! initialize "CPUWatcher initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:06'! isMonitoring ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 10/31/2001 10:50'! monitorPreferenceChanged Preferences cpuWatcherEnabled ifTrue: [ self startMonitoring ] ifFalse: [ self stopMonitoring ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! shutDown self stopMonitoring.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:17'! startMonitoring "CPUWatcher startMonitoring" ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:16'! startMonitoringPeriod: pd rate: rt threshold: th "CPUWatcher startMonitoring" CurrentCPUWatcher ifNotNil: [ ^CurrentCPUWatcher startMonitoring. ]. CurrentCPUWatcher _ (self new) monitorProcessPeriod: pd sampleRate: rt; threshold: th; yourself. ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! startUp self monitorPreferenceChanged.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:05'! stopMonitoring "CPUWatcher stopMonitoring" CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. CurrentCPUWatcher _ nil. ! ! !CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'! isResumable ^true! ! !CachingCodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'! httpRequestClass ^CachedHTTPDownloadRequest ! ! !CachingMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/21/2003 23:03'! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." | myBnds rectList | myBnds := self fullBounds. (cacheCanvas isNil or: [cacheCanvas extent ~= myBnds extent]) ifTrue: [cacheCanvas := (aCanvas allocateForm: myBnds extent) getCanvas. cacheCanvas translateBy: myBnds origin negated during: [:tempCanvas | super fullDrawOn: tempCanvas]. ^self]. "incrementally update the cache canvas" rectList := damageRecorder invalidRectsFullBounds: (0 @ 0 extent: myBnds extent). damageRecorder reset. rectList do: [:r | cacheCanvas translateTo: myBnds origin negated clippingTo: r during: [:c | c fillColor: Color transparent. "clear to transparent" super fullDrawOn: c]]! ! !CachingMorph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:14'! fullDrawOn: aCanvas (aCanvas isVisible: self fullBounds) ifFalse:[^self]. self updateCacheCanvas: aCanvas. aCanvas cache: self fullBounds using: cacheCanvas form during:[:cachingCanvas| super fullDrawOn: cachingCanvas]. ! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:48'! initialize "initialize the state of the receiver" super initialize. "" damageRecorder _ DamageRecorder new! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:22'! asAlphaBlendingCanvas: alpha ^(AlphaBlendingCanvas on: self) alpha: alpha! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'! asShadowDrawingCanvas: aColor ^(ShadowDrawingCanvas on: self) shadowColor: aColor! ! !Canvas methodsFor: 'drawing' stamp: 'aoy 2/15/2003 21:41'! line: pt1 to: pt2 width: width color: color1 dashLength: s1 secondColor: color2 secondDashLength: s2 startingOffset: startingOffset "Draw a line using the given width, colors and dash lengths. Originally written by Stephan Rudlof; tweaked by Dan Ingalls to use startingOffset for sliding offset as in 'ants' animations. Returns the sum of the starting offset and the length of this line." | dist deltaBig colors nextPhase segmentOffset phase segmentLength startPoint distDone endPoint segLens | dist := pt1 dist: pt2. dist = 0 ifTrue: [^startingOffset]. s1 = 0 & (s2 = 0) ifTrue: [^startingOffset]. deltaBig := pt2 - pt1. colors := { color1. color2}. segLens := { s1 asFloat. s2 asFloat}. nextPhase := { 2. 1}. "Figure out what phase we are in and how far, given startingOffset." segmentOffset := startingOffset \\ (s1 + s2). segmentLength := segmentOffset < s1 ifTrue: [phase := 1. s1 - segmentOffset] ifFalse: [phase := 2. s1 + s2 - segmentOffset]. startPoint := pt1. distDone := 0.0. [distDone < dist] whileTrue: [segmentLength := segmentLength min: dist - distDone. endPoint := startPoint + (deltaBig * segmentLength / dist). self line: startPoint truncated to: endPoint truncated width: width color: (colors at: phase). distDone := distDone + segmentLength. phase := nextPhase at: phase. startPoint := endPoint. segmentLength := segLens at: phase]. ^startingOffset + dist! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'! drawMorph: aMorph self draw: aMorph! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 15:23'! fullDrawMorph: aMorph self fullDraw: aMorph! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph during: aBlock ^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/10/2004 17:19'! translucentImage: aForm at: aPoint sourceRect: sourceRect "Draw a translucent image using the best available way of representing translucency. Note: This will be fixed in the future." self shadowColor ifNotNil:[ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. (self depth < 32 or:[aForm isTranslucent not]) ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect]. self image: aForm at: aPoint sourceRect: sourceRect rule: Form blend! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:44'! warpImage: aForm transform: aTransform "Warp the given form using aTransform" ^self warpImage: aForm transform: aTransform at: 0@0! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/28/2001 23:54'! warpImage: aForm transform: aTransform at: extraOffset "Warp the given form using aTransform. TODO: Use transform to figure out appropriate cell size" ^self warpImage: aForm transform: aTransform at: extraOffset sourceRect: aForm boundingBox cellSize: 1! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 12/29/2001 00:20'! warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 8/25/2001 17:27'! fillRectangle: aRectangle fillStyle: aFillStyle borderStyle: aBorderStyle "Fill the given rectangle." self fillRectangle: (aRectangle insetBy: aBorderStyle width) fillStyle: aFillStyle. aBorderStyle frameRectangle: aRectangle on: self! ! !Canvas methodsFor: 'drawing-support' stamp: 'gm 2/22/2003 14:53'! cache: aRectangle using: aCache during: aBlock "Cache the execution of aBlock by the given cache. Note: At some point we may want to actually *create* the cache here; for now we're only using it." (aCache notNil and: [(aCache isForm) and: [aCache extent = aRectangle extent]]) ifTrue: [^self paintImage: aCache at: aRectangle origin]. aBlock value: self! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:35'! drawString: s at: pt ^ self drawString: s from: 1 to: s size at: pt font: nil color: Color black! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:25'! drawString: s at: pt font: aFont color: aColor ^ self drawString: s from: 1 to: s size at: pt font: aFont color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:36'! drawString: s from: firstIndex to: lastIndex at: pt font: font color: aColor self drawString: s from: firstIndex to: lastIndex in: (pt extent: 10000@10000) font: font color: aColor! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/30/2001 20:37'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:39'! drawString: s in: boundsRect ^self drawString: s from: 1 to: s size in: boundsRect font: nil color: Color black! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:13'! drawString: s in: boundsRect font: fontOrNil color: c ^self drawString: s from: 1 to: s size in: boundsRect font: fontOrNil color: c! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! text: s at: pt font: fontOrNil color: c "OBSOLETE" ^ self drawString: s at: pt font: fontOrNil color: c! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:40'! text: s bounds: boundsRect font: fontOrNil color: c "OBSOLETE" ^self drawString: s in: boundsRect font: fontOrNil color: c! ! !Canvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! isPostscriptCanvas ^false! ! !Canvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Privately used for blending forms w/ constant alpha. Fall back to simpler case by defaul." ^self image: aForm at: aPoint sourceRect: sourceRect rule: rule! ! !CanvasCharacterScanner methodsFor: 'scanning' stamp: 'aoy 2/15/2003 21:24'! displayLine: textLine offset: offset leftInRun: leftInRun "largely copied from DisplayScanner's routine" | nowLeftInRun done startLoc startIndex stopCondition | line := textLine. foregroundColor ifNil: [foregroundColor := Color black]. leftMargin := (line leftMarginForAlignment: alignment) + offset x. rightMargin := line rightMargin + offset x. lineY := line top + offset y. lastIndex := textLine first. nowLeftInRun := leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" text runLengthFor: lastIndex] ifFalse: [leftInRun]. runX := destX := leftMargin. runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. spaceCount := 0. done := false. [done] whileFalse: ["remember where this portion of the line starts" startLoc := destX @ destY. startIndex := lastIndex. "find the end of this portion of the line" stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "displaying: false" "display that portion of the line" canvas drawString: text string from: startIndex to: lastIndex at: startLoc font: font color: foregroundColor. "handle the stop condition" done := self perform: stopCondition]. ^runStopIndex - lastIndex! ! !CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). ! ! !CanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! tab destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastIndex _ lastIndex + 1. ^ false! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40'! defaultTextColor defaultTextColor ifNil:[defaultTextColor _ Color black]. ^defaultTextColor! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'yo 6/23/2003 18:09'! defaultTextColor: color "This defaultTextColor inst var is equivalent to paragraphColor of DisplayScanner." defaultTextColor _ color. ! ! !CanvasCharacterScanner methodsFor: 'private' stamp: 'mu 8/9/2003 22:40'! setFont foregroundColor _ self defaultTextColor. super setFont. destY _ lineY + line baseline - font ascent! ! !CanvasCharacterScanner methodsFor: 'object fileIn' stamp: 'nk 6/17/2003 15:30'! convertToCurrentVersion: varDict refStream: smartRefStrm "From Squeak3.5 [latest update: #5180] on 17 June 2003" varDict at: 'defaultTextColor' put: Color black. ^ super convertToCurrentVersion: varDict refStream: smartRefStrm! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:36'! addFontSetToCache: command | index font | index := self class decodeInteger: command second. font := self class decodeFontSet: command third. index > fonts size ifTrue: [ | newFonts | newFonts := Array new: index. newFonts replaceFrom: 1 to: fonts size with: fonts. fonts := newFonts ]. fonts at: index put: font ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 3/21/2003 23:02'! addTTCFontToCache: command | index font | index := self class decodeInteger: command second. font := self class decodeTTCFont: command third. index > fonts size ifTrue: [ | newFonts | newFonts := Array new: index. newFonts replaceFrom: 1 to: fonts size with: fonts. fonts := newFonts ]. fonts at: index put: font. ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42'! drawBalloonOval: command | aRectangle aFillStyle borderWidth borderColor | aRectangle := self class decodeRectangle: command second. aFillStyle := self class decodeFillStyle: command third. borderWidth := self class decodeInteger: command fourth. borderColor := self class decodeColor: (command fifth). self drawCommand: [:c | c asBalloonCanvas fillOval: aRectangle fillStyle: aFillStyle borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:42'! drawBalloonRect: command | aRectangle aFillStyle | aRectangle := self class decodeRectangle: (command second). aFillStyle := self class decodeFillStyle: command third. self drawCommand: [:c | c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:24'! drawImage: command | image point sourceRect rule cacheID cacheNew previousImage | image := self class decodeImage: command second. point := self class decodePoint: command third. sourceRect := self class decodeRectangle: command fourth. rule := self class decodeInteger: command fifth. command size >= 7 ifTrue: [false ifTrue: [self showSpaceUsed]. "debugging" cacheID := self class decodeInteger: (command sixth). cacheNew := (self class decodeInteger: command seventh) = 1. cacheID > 0 ifTrue: [ cacheNew ifTrue: [CachedForms at: cacheID put: image] ifFalse: [previousImage := CachedForms at: cacheID. image ifNil: [image := previousImage] ifNotNil: [(previousImage notNil and: [image depth > 8]) ifTrue: [image := previousImage addDeltasFrom: image]. CachedForms at: cacheID put: image]]]]. self drawCommand: [:c | c image: image at: point sourceRect: sourceRect rule: rule]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43'! drawInfiniteFill: command | aRectangle aFillStyle | aRectangle := self class decodeRectangle: (command second). aFillStyle := InfiniteForm with: (self class decodeImage: command third). self drawCommand: [:c | c asBalloonCanvas fillRectangle: aRectangle fillStyle: aFillStyle]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:18'! drawLine: command | verb pt1Enc pt2Enc widthEnc colorEnc pt1 pt2 width color | verb _ command first. pt1Enc _ command second. pt2Enc _ command third. widthEnc _ command fourth. colorEnc _ command fifth. "" pt1 _ self class decodePoint: pt1Enc. pt2 _ self class decodePoint: pt2Enc. width _ self class decodeInteger: widthEnc. color _ self class decodeColor: colorEnc. "" self drawCommand: [:c | c line: pt1 to: pt2 width: width color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:37'! drawMultiText: command | boundsEnc colorEnc text bounds color fontIndexEnc fontIndex | text := MultiString fromByteArray: (command at: 2) asByteArray. "text asByteArray printString displayAt: 800@0." "self halt." boundsEnc := command at: 3. fontIndexEnc := command at: 4. colorEnc := command at: 5. bounds _ self class decodeRectangle: boundsEnc. fontIndex := self class decodeInteger: fontIndexEnc. color _ self class decodeColor: colorEnc. self drawCommand: [ :c | c drawString: text in: bounds font: (fonts at: fontIndex) color: color ] ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:19'! drawOval: command | verb rectEnc colorEnc borderWidthEnc borderColorEnc rect color borderWidth borderColor | verb _ command first. rectEnc _ command second. colorEnc _ command third. borderWidthEnc _ command fourth. borderColorEnc _ command fifth. "" rect _ self class decodeRectangle: rectEnc. color _ self class decodeColor: colorEnc. borderWidth _ self class decodeInteger: borderWidthEnc. borderColor _ self class decodeColor: borderColorEnc. "" self drawCommand: [:c | c fillOval: rect color: color borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:43'! drawPoly: command | verticesEnc fillColorEnc borderWidthEnc borderColorEnc vertices fillColor borderWidth borderColor | fillColorEnc := command second. borderWidthEnc := command third. borderColorEnc := command fourth. verticesEnc := command copyFrom: 5 to: command size. fillColor := self class decodeColor: fillColorEnc. borderWidth := self class decodeInteger: borderWidthEnc. borderColor := self class decodeColor: borderColorEnc. vertices := verticesEnc collect: [:enc | self class decodePoint: enc]. self drawCommand: [:c | c drawPolygon: vertices color: fillColor borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 13:19'! drawRect: command | verb rectEnc fillColorEnc borderWidthEnc borderColorEnc rect fillColor borderWidth borderColor | verb _ command first. rectEnc _ command second. fillColorEnc _ command third. borderWidthEnc _ command fourth. borderColorEnc _ command fifth. "" rect _ self class decodeRectangle: rectEnc. fillColor _ self class decodeColor: fillColorEnc. borderWidth _ self class decodeInteger: borderWidthEnc. borderColor _ self class decodeColor: borderColorEnc. "" self drawCommand: [:c | c frameAndFillRectangle: rect fillColor: fillColor borderWidth: borderWidth borderColor: borderColor]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'! drawStencil: command | stencilFormEnc locationEnc sourceRectEnc colorEnc stencilForm location sourceRect color | stencilFormEnc := command second. locationEnc := command third. sourceRectEnc := command fourth. colorEnc := command fifth. stencilForm := self class decodeImage: stencilFormEnc. location := self class decodePoint: locationEnc. sourceRect := self class decodeRectangle: sourceRectEnc. color := self class decodeColor: colorEnc. self drawCommand: [:executor | executor stencil: stencilForm at: location sourceRect: sourceRect color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'! drawText: command | boundsEnc colorEnc text bounds color fontIndexEnc fontIndex | text := command second. boundsEnc := command third. fontIndexEnc := command fourth. colorEnc := command fifth. bounds := self class decodeRectangle: boundsEnc. fontIndex := self class decodeInteger: fontIndexEnc. color := self class decodeColor: colorEnc. self drawCommand: [:c | c drawString: text in: bounds font: (fonts at: fontIndex) color: color]! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'! extentDepth: command | depth extent | extent := self class decodePoint: (command second). depth := self class decodeInteger: (command third). drawingCanvas := FormCanvas extent: extent depth: depth! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'nk 6/25/2003 12:42'! processCommand: command onForceDo: forceBlock "Decode the given string command and perform the required action. If the command is a forceToScreen command, also pass the forceBlock. The previous chained equality tests and conditionals have been replaced by a lookup table in my class variable DecodeTable, which is set in the class-side initialize method." | verb verbCode selector | command isEmpty ifTrue: [ ^self ]. verb _ command first. verbCode := verb first. selector _ DecodeTable at: (verbCode asciiValue + 1) ifAbsent: [ self error: 'unknown command: ', verb ]. "note: codeForce is the only odd one" ^(selector == #forceToScreen:) ifTrue: [ self forceToScreen: command withBlock: forceBlock ] ifFalse: [ self perform: selector withArguments: { command } ] ! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'! releaseImage: command | cacheID | CachedForms ifNil: [^self]. cacheID := self class decodeInteger: (command second). CachedForms at: cacheID put: nil! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:44'! setClip: command | clipRectEnc | clipRectEnc := command second. clipRect := self class decodeRectangle: clipRectEnc! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'dgd 2/22/2003 18:45'! setTransform: command | transformEnc | transformEnc := command second. transform := self class decodeTransform: transformEnc! ! !CanvasDecoder methodsFor: 'decoding' stamp: 'RAA 3/3/2001 18:29'! shadowColor: command drawingCanvas shadowColor: ( command second = '0' ifTrue: [nil] ifFalse: [self class decodeColor: command second] ) ! ! !CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 10/23/2002 23:39'! decodeFontSet: fontString ^ StrikeFontSet fontNamed: fontString ! ! !CanvasDecoder class methodsFor: 'decoding' stamp: 'yo 6/23/2003 20:12'! decodeTTCFont: fontString "Decode a string that consists of (e.g. 'ComicSansMS 12 0') into a proper instance." | first second | first _ fontString indexOf: $ startingAt: 1. second _ fontString indexOf: $ startingAt: first + 1. (first ~= 0 and: [second ~= 0]) ifTrue: [ ^ (TTCFont family: (fontString copyFrom: 1 to: (first - 1)) size: (fontString copyFrom: first + 1 to: second - 1) asNumber) emphasized: (fontString copyFrom: second + 1 to: fontString size) asNumber. ]. ^ TextStyle defaultFont. ! ! !CanvasDecoder class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! connection: aConnection ^(self new) connection: aConnection; yourself! ! !CanvasDecoder class methodsFor: 'decode table modification' stamp: 'nk 6/25/2003 12:49'! decodeVerb: verb toSelector: selector "verb is a single character which will be ferformed by my instances using selector" DecodeTable at: verb asciiValue + 1 put: selector. ! ! !CanvasDecoder class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 12:45'! initialize "CanvasDecoder initialize" "Set up my cache and decode table if necessary." CachedForms ifNil: [CachedForms := Array new: 100]. DecodeTable ifNotNil: [ ^self ]. DecodeTable _ Array new: 128. #((codeClip setClip:) (codeTransform setTransform:) (codeText drawText:) (codeLine drawLine:) (codeRect drawRect:) (codeBalloonRect drawBalloonRect:) (codeBalloonOval drawBalloonOval:) (codeInfiniteFill drawInfiniteFill:) (codeOval drawOval:) (codeImage drawImage:) (codeReleaseCache releaseImage:) (codePoly drawPoly:) (codeStencil drawStencil:) (codeForce forceToScreen:) (codeFont addFontToCache:) (codeTTCFont addTTCFontToCache:) (codeExtentDepth extentDepth:) (codeShadowColor shadowColor:)) do: [ :arr | DecodeTable at: ((CanvasEncoder perform: arr first) asciiValue + 1) put: arr second ]. ! ! !CanvasDecoder class methodsFor: 'class initialization' stamp: 'nk 6/25/2003 12:46'! reinitialize "CanvasDecoder reinitialize" "Set up my cache and decode table, removing old contents." CachedForms _ nil. DecodeTable _ nil. self initialize. ! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'yo 10/23/2002 23:40'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c | fontIndex str | fontIndex := self establishFont: (fontOrNil ifNil: [ TextStyle defaultFont ]). str _ s asString. str class = MultiString ifTrue: [ self sendCommand: { String with: CanvasEncoder codeMultiText. (str copyFrom: firstIndex to: lastIndex) asByteArray asString. self class encodeRectangle: boundsRect. self class encodeInteger: fontIndex. self class encodeColor: c } ] ifFalse: [ self sendCommand: { String with: CanvasEncoder codeText. s asString copyFrom: firstIndex to: lastIndex. self class encodeRectangle: boundsRect. self class encodeInteger: fontIndex. self class encodeColor: c } ]. ! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'RAA 3/3/2001 18:26'! shadowColor: aFillStyle self sendCommand: { String with: CanvasEncoder codeShadowColor. aFillStyle ifNil: ['0'] ifNotNil: [aFillStyle encodeForRemoteCanvas]. }! ! !CanvasEncoder methodsFor: 'drawing' stamp: 'dgd 2/22/2003 19:01'! testCache: anObject | firstFree cachedObject newEntry | cachingEnabled ifFalse: [cachedObjects := nil. ^nil]. cachedObjects ifNil: [cachedObjects := (1 to: 100) collect: [:x | { WeakArray new: 1. nil. nil. nil}]]. self purgeCache. firstFree := nil. cachedObjects withIndexDo: [:each :index | cachedObject := each first first. firstFree ifNil: [cachedObject ifNil: [firstFree := index]]. cachedObject == anObject ifTrue: [each at: 2 put: (each second) + 1. ^{ index. false. each}]]. firstFree ifNil: [^nil]. newEntry := { WeakArray with: anObject. 1. Time millisecondClockValue. nil}. cachedObjects at: firstFree put: newEntry. ^{ firstFree. true. newEntry}! ! !CanvasEncoder methodsFor: 'fonts' stamp: 'nk 6/25/2003 12:58'! sendFont: aFont atIndex: index "Transmits the given fint to the other side" | code | code _ CanvasEncoder codeFont. aFont isTTCFont ifTrue: [code _ CanvasEncoder codeTTCFont]. self sendCommand: { String with: code. self class encodeInteger: index. self class encodeFont: aFont }. ! ! !CanvasEncoder methodsFor: 'private' stamp: 'dgd 2/22/2003 14:41'! sendCommand: stringArray | bucket | connection ifNil: [^self]. connection isConnected ifFalse: [^self]. connection nextPut: stringArray. SentTypesAndSizes ifNil: [^self]. bucket := SentTypesAndSizes at: stringArray first ifAbsentPut: [{ 0. 0. 0}]. bucket at: 1 put: bucket first + 1. bucket at: 2 put: (bucket second) + (stringArray inject: 4 into: [:sum :array | sum + (array size + 4)])! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! explainTestVars " CanvasEncoder explainTestVars " | answer total oneBillion data putter nReps | SimpleCounters ifNil: [^ Beeper beep]. total _ 0. oneBillion _ 1000 * 1000 * 1000. answer _ String streamContents: [ :strm | data _ SimpleCounters copy. putter _ [ :msg :index :nSec | nReps _ data at: index. total _ total + (nSec * nReps). strm nextPutAll: nReps asStringWithCommas,' * ',nSec printString,' ', (nSec * nReps / oneBillion roundTo: 0.01) printString,' secs for ',msg; cr ]. putter value: 'string socket' value: 1 value: 8000. putter value: 'rectangles' value: 2 value: 40000. putter value: 'points' value: 3 value: 18000. putter value: 'colors' value: 4 value: 8000. ]. StringHolder new contents: answer; openLabel: 'put integer times'. ! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'nk 8/30/2004 07:47'! nameForCode: aStringOrChar | ch | ch _ (aStringOrChar isString) ifTrue: [aStringOrChar first] ifFalse: [aStringOrChar]. ch == self codeBalloonOval ifTrue: [^'balloon oval']. ch == self codeBalloonRect ifTrue: [^'balloon rectangle']. ch == self codeClip ifTrue: [^'clip']. ch == self codeExtentDepth ifTrue: [^'codeExtentDepth']. ch == self codeFont ifTrue: [^'codeFont']. ch == self codeTTCFont ifTrue: [^'codeTTCFont']. ch == self codeForce ifTrue: [^'codeForce']. ch == self codeImage ifTrue: [^'codeImage']. ch == self codeLine ifTrue: [^'codeLine']. ch == self codeOval ifTrue: [^'codeOval']. ch == self codePoly ifTrue: [^'codePoly']. ch == self codeRect ifTrue: [^'codeRect']. ch == self codeReleaseCache ifTrue: [^'codeReleaseCache']. ch == self codeStencil ifTrue: [^'codeStencil']. ch == self codeText ifTrue: [^'codeText']. ch == self codeTransform ifTrue: [^'codeTransform']. ch == self codeInfiniteFill ifTrue: [^'codeInfiniteFill']. ch == self codeShadowColor ifTrue: [^'shadowColor']. ^'????' ! ! !CanvasEncoder class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! showStats " CanvasEncoder showStats " | answer bucket | SentTypesAndSizes ifNil: [^Beeper beep]. answer _ WriteStream on: String new. SentTypesAndSizes keys asSortedCollection do: [ :each | bucket _ SentTypesAndSizes at: each. answer nextPutAll: each printString,' ', bucket first printString,' ', bucket second asStringWithCommas,' ', (self nameForCode: each); cr. ]. StringHolder new contents: answer contents; openLabel: 'send/receive stats'. ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:41'! codeFontSet ^ $S ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 10/23/2002 23:42'! codeMultiText ^ $c ! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'RAA 3/3/2001 18:24'! codeShadowColor ^$s! ! !CanvasEncoder class methodsFor: 'codes' stamp: 'yo 3/21/2003 23:00'! codeTTCFont ^ $T. ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:44'! matchIndex | tms | "Index of one we are looking at, in the cards that matched the last search with this template." tms _ self class classPool at: #TemplateMatches ifAbsent: [^ 0]. ^ (tms at: self ifAbsent: [#(0 0)]) second. ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:47'! matchIndex: newPlace | tms pair | "One we are looking at, in cards that matched the last template search." tms _ self class classPool at: #TemplateMatches ifAbsent: [ self class addClassVarName: 'TemplateMatches'. self class classPool at: #TemplateMatches put: IdentityDictionary new]. pair _ tms at: self ifAbsent: [tms at: self put: (Array new: 2)]. pair at: 2 put: newPlace. newPlace = 0 ifTrue: [^ self]. pair first ifNil: [^ self]. (costume valueOfProperty: #myStack ifAbsent: [^ self]) goToCard: ((pair first "list") at: newPlace). self changed: #matchIndex. "update my selection" ! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/31/2001 16:46'! matchNames | list str ll tms stk crds | "List of names of cards that matched the last template search." tms _ self class classPool at: #TemplateMatches ifAbsent: [^ #()]. list _ (tms at: self ifAbsent: [#(#() 0)]) first. stk _ costume valueOfProperty: #myStack ifAbsent: [nil]. crds _ stk ifNil: [#()] ifNotNil: [stk cards]. ^ list collect: [:cd | str _ ''. (ll _ cd allStringsAfter: nil) ifNotNil: [ str _ ll inject: '' into: [:strr :this | strr, this]]. (str copyFrom: 1 to: (30 min: str size)), '... (' , (crds indexOf: cd) printString, ')']. "Maybe include a card title?"! ! !CardPlayer methodsFor: 'as template' stamp: 'tk 5/29/2001 22:49'! results "Return my (cardlist index) pair from the last search" ^ (self class classPool at: #TemplateMatches ifAbsent: [^ Array new: 2]) at: self ! ! !CardPlayer methodsFor: 'card data' stamp: 'dgd 2/22/2003 14:43'! allStringsAfter: aText "return an OrderedCollection of strings of text in my instance vars. If aText is non-nil, begin with that object." | list ok instVarValue string | list := OrderedCollection new. ok := aText isNil. self class variableDocks do: [:vdock | instVarValue := self perform: vdock playerGetSelector. ok ifFalse: [ok := instVarValue == aText]. "and do this one too" ok ifTrue: [string := nil. instVarValue isString ifTrue: [string := instVarValue]. instVarValue isText ifTrue: [string := instVarValue string]. instVarValue isNumber ifTrue: [string := instVarValue printString]. instVarValue isMorph ifTrue: [string := instVarValue userString]. "not used" string ifNotNil: [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. privateMorphs ifNotNil: [privateMorphs do: [:mm | list addAll: (mm allStringsAfter: nil)]]. ^list! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:42'! asKeys | keys kk vd gotData | "Take my fields, tokenize the text, and return as an array in the same order as variableDocks. Simple background fields on the top level. If no data, return nil." keys _ self class variableDocks copy. gotData _ false. 1 to: keys size do: [:ind | kk _ nil. vd _ self class variableDocks at: ind. vd type == #text ifTrue: [ kk _ (self perform: vd playerGetSelector) string findTokens: Character separators. kk isEmpty ifTrue: [kk _ nil] ifFalse: [gotData _ true]]. keys at: ind put: kk]. ^ gotData ifTrue: [keys] ifFalse: [nil]! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/25/2001 17:02'! match: keys fields: docks | longString | "see if each key occurs in my corresponding text instance." keys withIndexDo: [:kk :ind | kk ifNotNil: [ longString _ (self perform: (docks at: ind) playerGetSelector) string. kk do: [:aKey | ((longString findString: aKey startingAt: 1 caseSensitive: false) > 0) ifFalse: [^ false]]]]. "all keys must match" ^ true! ! !CardPlayer methodsFor: 'card data' stamp: 'tk 5/7/2001 15:51'! url "For now, don't know we could be on a server" ^ nil! ! !CardPlayer methodsFor: 'scripts-kernel' stamp: 'svp 10/15/2001 14:44'! renameScript: oldSelector newSelector: newSelector "Find all buttons that fire this script and tell them the new name" | stack | super renameScript: oldSelector newSelector: newSelector. costume allMorphsDo: [:mm | self retargetButton: mm oldSelector: oldSelector newSelector: newSelector]. stack _ costume valueOfProperty: #myStack. stack ifNotNil: [stack cards do: [:cc | cc privateMorphs do: [:pp | pp allMorphsDo: [:mm | self retargetButton: mm oldSelector: oldSelector newSelector: newSelector]]]]! ! !CardPlayer methodsFor: 'scripts-kernel' stamp: 'tk 9/29/2001 10:27'! retargetButton: mm oldSelector: oldSelector newSelector: newSelector "changing the name of a script -- tell any buttons that fire it" (mm respondsTo: #scriptSelector) ifTrue: [ mm scriptSelector == oldSelector ifTrue: [ mm scriptSelector: newSelector. mm setNameTo: newSelector]]. (mm respondsTo: #actionSelector) ifTrue: [ mm actionSelector == oldSelector ifTrue: [ mm target class == self class ifTrue: [ mm actionSelector: newSelector. mm setNameTo: newSelector]]]. ! ! !CardPlayer methodsFor: 'slots-kernel' stamp: 'sw 7/28/2004 21:03'! tileReferringToSelf "Answer a tile that refers to the receiver. For CardPlayer, want 'self', not the specific name of this card. Script needs to work for any card of the background." Preferences universalTiles ifTrue: [^ self universalTileReferringToSelf]. ^ TileMorph new setToReferTo: self! ! !CardPlayer commentStamp: '' prior: 0! CardPlayer Instance variables of the Uniclass represent the data in the "fields" of each card in the stack. Each Instance variable is some kind of value holder. The code for the *buttons* on the background resides in the CardPlayer uniclass. privateMorphs -- OrderedCollection of objects specific to this card. Individual CardPlayer classes need to store the search results of any instances that are templates. As a hack, we use a class variable TemplateMatches in each individual class (CardPlayer21). It is initialized in #matchIndex:. TemplateMatches an IndentityDictionary of (aCardPlayer -> (list of matching cards, index in that list)) ! !CardPlayer class methodsFor: 'compiling' stamp: 'tk 9/28/2001 11:42'! wantsChangeSetLogging "Log changes for CardPlayer itself, but not for automatically-created subclasses like CardPlayer1, CardPlayer2, but *do* log it for uniclasses that have been manually renamed." ^ (self == CardPlayer or: [(self name beginsWith: 'CardPlayer') not]) or: [Preferences universalTiles]! ! !CardPlayer class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'! compileAccessorsFor: varName "Compile instance-variable accessor methods for the given variable name" | nameString | nameString _ varName asString capitalized. self compileSilently: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileSilently: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !CardPlayer class methodsFor: 'slots' stamp: 'NS 1/30/2004 13:11'! removeAccessorsFor: varName "Remove the instance-variable accessor methods associated with varName" | nameString | nameString _ varName asString capitalized. self removeSelectorSilently: ('get', nameString) asSymbol. self removeSelectorSilently: ('set', nameString, ':') asSymbol! ! !CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'sw 12/6/2001 20:36'! resortInstanceVariables: newList "Accept a new ordering for instance variables" variableDocks _ newList collect: [:aName | variableDocks detect: [:d | d variableName = aName]]. self setNewInstVarNames: newList asOrderedCollection. self newVariableDocks: variableDocks. ! ! !CardPlayer class methodsFor: 'user-defined inst vars' stamp: 'tk 8/26/2001 16:58'! setNewInstVarNames: listOfStrings "Make listOfStrings be the new list of instance variable names for the receiver" | disappearing firstAppearing instVarString instVarList | instVarList _ self instVarNames asOrderedCollection. disappearing _ instVarList copy. disappearing removeAllFoundIn: listOfStrings. disappearing do: [:oldName | self removeAccessorsFor: oldName]. firstAppearing _ listOfStrings copy. firstAppearing removeAllFoundIn: instVarList. instVarString _ String streamContents: [:aStream | listOfStrings do: [:aString | aStream nextPutAll: aString; nextPut: $ ]]. superclass subclass: self name instanceVariableNames: instVarString classVariableNames: '' poolDictionaries: '' category: self categoryForUniclasses. firstAppearing do: [:newName | self compileAccessorsFor: newName]. ! ! !CascadeNode methodsFor: 'tiles' stamp: 'RAA 2/22/2001 13:56'! asMorphicSyntaxIn: parent ^parent cascadeNode: self receiver: receiver messages: messages ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: newCategory ^ self addCategory: newCategory before: nil ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: catString before: nextCategory "Add a new category named heading. If default category exists and is empty, remove it. If nextCategory is nil, then add the new one at the end, otherwise, insert it before nextCategory." | index newCategory | newCategory _ catString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^self]. "heading already exists, so done" index _ categoryArray indexOf: nextCategory ifAbsent: [categoryArray size + 1]. categoryArray _ categoryArray copyReplaceFrom: index to: index-1 with: (Array with: newCategory). categoryStops _ categoryStops copyReplaceFrom: index to: index-1 with: (Array with: (index = 1 ifTrue: [0] ifFalse: [categoryStops at: index-1])). "remove empty default category" (newCategory ~= Default and: [(self listAtCategoryNamed: Default) isEmpty]) ifTrue: [self removeCategory: Default]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! allMethodSelectors "give a list of all method selectors." ^ elementArray copy sort! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:29'! categories "Answer an Array of categories (names)." categoryArray isNil ifTrue: [^ nil]. (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! categories: anArray "Reorder my categories to be in order of the argument, anArray. If the resulting organization does not include all elements, then give an error." | newCategories newStops newElements catName list runningTotal | newCategories _ Array new: anArray size. newStops _ Array new: anArray size. newElements _ Array new: 0. runningTotal _ 0. 1 to: anArray size do: [:i | catName _ (anArray at: i) asSymbol. list _ self listAtCategoryNamed: catName. newElements _ newElements, list. newCategories at: i put: catName. newStops at: i put: (runningTotal _ runningTotal + list size)]. elementArray do: [:element | "check to be sure all elements are included" (newElements includes: element) ifFalse: [^self error: 'New categories must match old ones']]. "Everything is good, now update my three arrays." categoryArray _ newCategories. categoryStops _ newStops. elementArray _ newElements! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! categoryOfElement: element "Answer the category associated with the argument, element." | index | index _ self numberOfCategoryOfElement: element. index = 0 ifTrue: [^nil] ifFalse: [^categoryArray at: index]! ! !Categorizer methodsFor: 'accessing' stamp: 'hmm 2/25/2005 10:53'! changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." | oldElements newElements newCategories newStops currentStop temp ii cc catSpec | oldElements _ elementArray asSet. newCategories _ Array new: categorySpecs size. newStops _ Array new: categorySpecs size. currentStop _ 0. newElements _ WriteStream on: (Array new: 16). 1 to: categorySpecs size do: [:i | | selectors | catSpec _ categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. selectors := catSpec allButFirst collect: [:each | each isSymbol ifTrue: [each] ifFalse: [each printString asSymbol]]. selectors asSortedCollection do: [:elem | (oldElements remove: elem ifAbsent: [nil]) notNil ifTrue: [newElements nextPut: elem. currentStop _ currentStop+1]]. newStops at: i put: currentStop]. "Ignore extra elements but don't lose any existing elements!!" oldElements _ oldElements collect: [:elem | Array with: (self categoryOfElement: elem) with: elem]. newElements _ newElements contents. categoryArray _ newCategories. (cc _ categoryArray asSet) size = categoryArray size ifFalse: ["has duplicate element" temp _ categoryArray asOrderedCollection. temp removeAll: categoryArray asSet asOrderedCollection. temp do: [:dup | ii _ categoryArray indexOf: dup. [dup _ (dup,' #2') asSymbol. cc includes: dup] whileTrue. cc add: dup. categoryArray at: ii put: dup]]. categoryStops _ newStops. elementArray _ newElements. oldElements do: [:pair | self classify: pair last under: pair first].! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs _ Scanner new scanTokens: aString. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [elementArray isEmpty]) ifTrue: [^ self setDefaultList: Array new]. ^ self changeFromCategorySpecs: categorySpecs! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classify: element under: heading self classify: element under: heading suppressIfDefault: true! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:54'! classify: element under: heading suppressIfDefault: aBoolean "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" | catName catIndex elemIndex realHeading | ((heading = NullCategory) or: [heading == nil]) ifTrue: [realHeading _ Default] ifFalse: [realHeading _ heading asSymbol]. (catName _ self categoryOfElement: element) = realHeading ifTrue: [^ self]. "done if already under that category" catName ~~ nil ifTrue: [(aBoolean and: [realHeading = Default]) ifTrue: [^ self]. "return if non-Default category already assigned in memory" self removeElement: element]. "remove if in another category" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. catIndex _ categoryArray indexOf: realHeading. elemIndex _ catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'! elementCategoryDict | dict firstIndex lastIndex | elementArray isNil ifTrue: [^ nil]. dict _ Dictionary new: elementArray size. 1to: categoryStops size do: [:cat | firstIndex _ self firstIndexOfCategoryNumber: cat. lastIndex _ self lastIndexOfCategoryNumber: cat. firstIndex to: lastIndex do: [:el | dict at: (elementArray at: el) put: (categoryArray at: cat)]. ]. ^ dict.! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNamed: categoryName | i | i _ categoryArray indexOf: categoryName ifAbsent: [^false]. ^self isEmptyCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:33'! isEmptyCategoryNumber: anInteger | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ true]. firstIndex _ self firstIndexOfCategoryNumber: anInteger. lastIndex _ self lastIndexOfCategoryNumber: anInteger. ^ firstIndex > lastIndex! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! listAtCategoryNamed: categoryName "Answer the array of elements associated with the name, categoryName." | i | i _ categoryArray indexOf: categoryName ifAbsent: [^Array new]. ^self listAtCategoryNumber: i! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 13:51'! listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." | firstIndex lastIndex | (anInteger < 1 or: [anInteger > categoryStops size]) ifTrue: [^ nil]. firstIndex _ self firstIndexOfCategoryNumber: anInteger. lastIndex _ self lastIndexOfCategoryNumber: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! numberOfCategoryOfElement: element "Answer the index of the category with which the argument, element, is associated." | categoryIndex elementIndex | categoryIndex _ 1. elementIndex _ 0. [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: ["point to correct category" [elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryIndex _ categoryIndex + 1]. "see if this is element" element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]]. ^0! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeCategory: cat "Remove the category named, cat. Create an error notificiation if the category has any elements in it." | index lastStop | index _ categoryArray indexOf: cat ifAbsent: [^self]. lastStop _ index = 1 ifTrue: [0] ifFalse: [categoryStops at: index - 1]. (categoryStops at: index) - lastStop > 0 ifTrue: [^self error: 'cannot remove non-empty category']. categoryArray _ categoryArray copyReplaceFrom: index to: index with: Array new. categoryStops _ categoryStops copyReplaceFrom: index to: index with: Array new. categoryArray size = 0 ifTrue: [categoryArray _ Array with: Default. categoryStops _ Array with: 0] ! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeElement: element "Remove the selector, element, from all categories." | categoryIndex elementIndex nextStop newElements | categoryIndex _ 1. elementIndex _ 0. nextStop _ 0. "nextStop keeps track of the stops in the new element array" newElements _ WriteStream on: (Array new: elementArray size). [(elementIndex _ elementIndex + 1) <= elementArray size] whileTrue: [[elementIndex > (categoryStops at: categoryIndex)] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. (elementArray at: elementIndex) = element ifFalse: [nextStop _ nextStop + 1. newElements nextPut: (elementArray at: elementIndex)]]. [categoryIndex <= categoryStops size] whileTrue: [categoryStops at: categoryIndex put: nextStop. categoryIndex _ categoryIndex + 1]. elementArray _ newElements contents! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! removeEmptyCategories "Remove empty categories." | categoryIndex currentStop keptCategories keptStops | keptCategories _ WriteStream on: (Array new: 16). keptStops _ WriteStream on: (Array new: 16). currentStop _ categoryIndex _ 0. [(categoryIndex _ categoryIndex + 1) <= categoryArray size] whileTrue: [(categoryStops at: categoryIndex) > currentStop ifTrue: [keptCategories nextPut: (categoryArray at: categoryIndex). keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]]. categoryArray _ keptCategories contents. categoryStops _ keptStops contents. categoryArray size = 0 ifTrue: [categoryArray _ Array with: Default. categoryStops _ Array with: 0] "ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! renameCategory: oldCatString toBe: newCatString "Rename a category. No action if new name already exists, or if old name does not exist." | index oldCategory newCategory | oldCategory _ oldCatString asSymbol. newCategory _ newCatString asSymbol. (categoryArray indexOf: newCategory) > 0 ifTrue: [^ self]. "new name exists, so no action" (index _ categoryArray indexOf: oldCategory) = 0 ifTrue: [^ self]. "old name not found, so no action" categoryArray _ categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCategory! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! sortCategories | privateCategories publicCategories newCategories | privateCategories _ self categories select: [:one | (one findString: 'private' startingAt: 1 caseSensitive: false) = 1]. publicCategories _ self categories copyWithoutAll: privateCategories. newCategories _ publicCategories asSortedCollection asOrderedCollection addAll: privateCategories asSortedCollection; asArray. self categories: newCategories! ! !Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! printOn: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space; nextPutAll: (elementArray at: elementIndex). elementIndex _ elementIndex + 1]. aStream nextPut: $); cr]! ! !Categorizer methodsFor: 'printing' stamp: 'NS 4/5/2004 17:44'! printOnStream: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream print: '('; write:(categoryArray at:i). " is the asString redundant? " [elementIndex <= (categoryStops at: i)] whileTrue: [aStream print:' '; write:(elementArray at: elementIndex). elementIndex _ elementIndex + 1]. aStream print:')'. aStream cr]! ! !Categorizer methodsFor: 'fileIn/Out' stamp: 'NS 4/5/2004 17:44'! scanFrom: aStream "Reads in the organization from the next chunk on aStream. Categories or elements not found in the definition are not affected. New elements are ignored." self changeFromString: aStream nextChunk. aStream skipStyleChunk.! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:44'! elementArray ^ elementArray! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:51'! firstIndexOfCategoryNumber: anInteger anInteger < 1 ifTrue: [^ nil]. ^ (anInteger > 1 ifTrue: [(categoryStops at: anInteger - 1) + 1] ifFalse: [1]).! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/6/2004 13:52'! lastIndexOfCategoryNumber: anInteger anInteger > categoryStops size ifTrue: [^ nil]. ^ categoryStops at: anInteger! ! !Categorizer methodsFor: 'private' stamp: 'NS 4/5/2004 17:50'! setDefaultList: aSortedCollection categoryArray _ Array with: Default. categoryStops _ Array with: aSortedCollection size. elementArray _ aSortedCollection asArray! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! allCategory "Return a symbol that represents the virtual all methods category." ^ '-- all --' asSymbol! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! default ^ Default! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/6/2004 11:48'! initialize " self initialize " Default _ 'as yet unclassified' asSymbol. NullCategory _ 'no messages' asSymbol.! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! nullCategory ^ NullCategory! ! !Categorizer class methodsFor: 'instance creation' stamp: 'NS 4/5/2004 17:44'! defaultList: aSortedCollection "Answer an instance of me with initial elements from the argument, aSortedCollection." ^self new setDefaultList: aSortedCollection! ! !Categorizer class methodsFor: 'documentation' stamp: 'NS 4/5/2004 17:44'! documentation "Instances consist of an Array of category names (categoryArray), each of which refers to an Array of elements (elementArray). This association is made through an Array of stop indices (categoryStops), each of which is the index in elementArray of the last element (if any) of the corresponding category. For example: categories _ Array with: 'firstCat' with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. elements _ Array with: #a with: #b with: #c with: #d. This means that category firstCat has only #a, secondCat has #b, #c, and #d, and thirdCat has no elements. This means that stops at: stops size must be the same as elements size." ! ! !Categorizer class methodsFor: 'housekeeping' stamp: 'NS 4/6/2004 11:48'! sortAllCategories self allSubInstances do: [:x | x sortCategories]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 7/7/2004 21:59'! adjustColorsAndBordersWithin "Adjust the colors and borders of submorphs to suit current fashion" self allMorphsDo: [:aMorph | (aMorph isKindOf: ViewerLine) ifTrue: [aMorph layoutInset: 1]. (aMorph isKindOf: TilePadMorph) ifTrue: [aMorph beTransparent]. (aMorph isKindOf: PhraseTileMorph) ifTrue: [aMorph beTransparent. aMorph borderWidth: 0]. (aMorph isKindOf: TileMorph) ifTrue: [aMorph borderWidth: 1]]. self borderWidth: 1! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 8/22/2002 14:00'! beReplacedByCategory: chosenCategory "Be replaced by a category pane pointed at the chosen category" self outerViewer replaceSubmorph: self by: (self outerViewer categoryViewerFor: chosenCategory) ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:55'! categoryNameWhoseTranslatedWordingIs: aWording "Answer the category name with the given wording" | result | result _ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording. ^ result ifNotNil: [result categoryName] ifNil: [aWording]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/12/2001 20:34'! categoryWhoseTranslatedWordingIs: aWording "Answer the elementCategory with the given wording" ^ self currentVocabulary categoryWhoseTranslatedWordingIs: aWording! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 10/30/2001 13:45'! categoryWording: aCategoryWording "Make the category with the given wording be my current one." | actualPane | (actualPane _ namePane renderedMorph) firstSubmorph contents: aCategoryWording; color: Color black. actualPane extent: actualPane firstSubmorph extent. self removeAllButFirstSubmorph. "that being the header" self addAllMorphs: ((scriptedPlayer tilePhrasesForCategory: chosenCategorySymbol inViewer: self)). self enforceTileColorPolicy. self secreteCategorySymbol. self world ifNotNil: [self world startSteppingSubmorphsOf: self]. self adjustColorsAndBordersWithin. owner ifNotNil: [owner isStandardViewer ifTrue: [owner fitFlap]]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 3/2/2004 23:53'! chooseCategory "The mouse went down on my category-list control; pop up a list of category choices" | aList aMenu reply aLinePosition lineList | aList _ scriptedPlayer categoriesForViewer: self. aLinePosition _ aList indexOf: #miscellaneous ifAbsent: [nil]. aList _ aList collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. lineList _ aLinePosition ifNil: [#()] ifNotNil: [Array with: aLinePosition]. aList size == 0 ifTrue: [aList add: ScriptingSystem nameForInstanceVariablesCategory translated]. aMenu _ CustomMenu labels: aList lines: lineList selections: aList. reply _ aMenu startUpWithCaption: 'category' translated. reply ifNil: [^ self]. self chooseCategoryWhoseTranslatedWordingIs: reply asSymbol ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:56'! chooseCategoryWhoseTranslatedWordingIs: aWording "Choose the category with the given wording" self chosenCategorySymbol: (self categoryNameWhoseTranslatedWordingIs: aWording) ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 22:43'! chosenCategorySymbol "Answer the inherent category currently being shown, not necessarily the same as the translated word." ^ chosenCategorySymbol ifNil: [self secreteCategorySymbol]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:49'! chosenCategorySymbol: aCategorySymbol "Make the given category be my current one." | aCategory wording | chosenCategorySymbol _ aCategorySymbol. aCategory _ self currentVocabulary categoryAt: chosenCategorySymbol. wording _ aCategory ifNil: [aCategorySymbol] ifNotNil: [aCategory wording]. self categoryWording: wording! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 2/23/2001 22:29'! currentCategory "Answer the symbol representing the receiver's currently-selected category" | current | current _ namePane renderedMorph firstSubmorph contents. ^ current ifNotNil: [current asSymbol] ifNil: [#basic]! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:57'! nextCategory "Change the receiver to point at the category following the one currently seen" | aList anIndex newIndex already aChoice | aList _ (scriptedPlayer categoriesForViewer: self) collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing]. anIndex _ aList indexOf: self currentCategory ifAbsent: [0]. newIndex _ anIndex = aList size ifTrue: [1] ifFalse: [anIndex + 1]. [already includes: (aChoice _ aList at: newIndex)] whileTrue: [newIndex _ (newIndex \\ aList size) + 1]. self chooseCategoryWhoseTranslatedWordingIs: aChoice! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:53'! previousCategory "Change the receiver to point at the category preceding the one currently seen" | aList anIndex newIndex already aChoice | aList _ (scriptedPlayer categoriesForViewer: self) collect: [:aCatSymbol | self currentVocabulary categoryWordingAt: aCatSymbol]. already _ self outerViewer ifNil: [#()] ifNotNil: [self outerViewer categoriesCurrentlyShowing]. anIndex _ aList indexOf: self currentCategory ifAbsent: [aList size + 1]. newIndex _ anIndex = 1 ifTrue: [aList size] ifFalse: [anIndex - 1]. [already includes: (aChoice _ aList at: newIndex)] whileTrue: [newIndex _ newIndex = 1 ifTrue: [aList size] ifFalse: [newIndex - 1]]. self chooseCategoryWhoseTranslatedWordingIs: aChoice! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 9/13/2001 19:50'! secreteCategorySymbol "Set my chosenCategorySymbol by translating back from its representation in the namePane. Answer the chosenCategorySymbol" | aCategory | aCategory _ self currentVocabulary categoryWhoseTranslatedWordingIs: self currentCategory. ^ chosenCategorySymbol _ aCategory ifNotNil: [aCategory categoryName] ifNil: [self currentCategory]! ! !CategoryViewer methodsFor: 'categories' stamp: 'nk 9/2/2004 19:37'! showCategoriesFor: aSymbol "Put up a pop-up list of categories in which aSymbol is filed; replace the receiver with a CategoryViewer for the one the user selects, if any" | allCategories aVocabulary hits meths chosen | aVocabulary _ self currentVocabulary. allCategories _ scriptedPlayer categoriesForVocabulary: aVocabulary limitClass: ProtoObject. hits _ allCategories select: [:aCategory | meths _ aVocabulary allMethodsInCategory: aCategory forInstance: scriptedPlayer ofClass: scriptedPlayer class. meths includes: aSymbol]. hits isEmpty ifTrue: [ ^self ]. chosen _ (SelectionMenu selections: hits) startUp. chosen isEmptyOrNil ifFalse: [self outerViewer addCategoryViewerFor: chosen atEnd: true] ! ! !CategoryViewer methodsFor: 'categories' stamp: 'sw 5/29/2001 11:41'! updateCategoryNameTo: aName "Update the category name, because of a language change." | actualPane | (actualPane _ namePane firstSubmorph) contents: aName; color: Color black. namePane extent: actualPane extent. self world ifNotNil: [self world startSteppingSubmorphsOf: self] ! ! !CategoryViewer methodsFor: 'e-toy support' stamp: 'sw 9/13/2001 19:16'! adoptVocabulary: aVocabulary "Adopt the given vocabulary as the one used in this viewer." | aCategory | chosenCategorySymbol ifNil: [^ self delete]. aCategory _ aVocabulary categoryAt: chosenCategorySymbol. aCategory ifNil: [self delete] ifNotNil: [self updateCategoryNameTo: aCategory wording]. super adoptVocabulary: aVocabulary! ! !CategoryViewer methodsFor: 'e-toy support' stamp: 'mir 7/15/2004 15:19'! localeChanged "Update myself to reflect the change in locale" chosenCategorySymbol ifNil: [^ self delete]. self updateCategoryNameTo: ((self currentVocabulary ifNil: [Vocabulary eToyVocabulary]) categoryWordingAt: chosenCategorySymbol)! ! !CategoryViewer methodsFor: 'editing pane' stamp: 'nb 6/17/2003 12:25'! contents: c notifying: k "later, spruce this up so that it can accept input such as new method source" Beeper beep. ^ false! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 7/25/2004 15:37'! addIsOverColorDetailTo: aRow "Special-casee code for the boolean-valued phrase variously known as is-over-color or sees-color." | clrTile | aRow addMorphBack: (Morph new color: self color; extent: 2@10). "spacer" aRow addMorphBack: (clrTile _ Color blue newTileMorphRepresentative). "The following commented-out code put a readout up; the readout was very nice, but was very consumptive of cpu time, which is why the is-over-color tile got removed from the viewer long ago. Now is-over-color is reinstated to the viewer, minus the expensive readout..." " aRow addMorphBack: (AlignmentMorph new beTransparent). readout _ UpdatingStringMorphWithArgument new target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil; argumentTarget: clrTile colorSwatch argumentGetSelector: #color. readout useDefaultFormat. aTile _ StringReadoutTile new typeColor: Color lightGray lighter. aTile addMorphBack: readout. aRow addMorphBack: aTile. aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20'! addOverlapsDetailTo: aRow "Disreputable magic: add necessary items to a viewer row abuilding for the overlaps phrase" aRow addMorphBack: (Morph new color: self color; extent: 2@10). "spacer" aRow addMorphBack: self tileForSelf. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" ! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:21'! addTouchesADetailTo: aRow | clrTile | aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" aRow addMorphBack: (clrTile _ self tileForSelf). aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" "readout _ UpdatingStringMorphWithArgument new target: scriptedPlayer; getSelector: #seesColor:; growable: false; putSelector: nil; argumentTarget: clrTile colorSwatch argumentGetSelector: #color. readout useDefaultFormat. aTile _ StringReadoutTile new typeColor: Color lightGray lighter. aTile addMorphBack: readout. aRow addMorphBack: aTile. aTile setLiteralTo: (scriptedPlayer seesColor: clrTile colorSwatch color) printString width: 30"! ! !CategoryViewer methodsFor: 'entries' stamp: 'md 11/14/2003 16:20'! infoButtonFor: aScriptOrSlotSymbol "Answer a fully-formed morph that will serve as the 'info button' alongside an entry corresponding to the given slot or script symbol. If no such button is appropriate, answer a transparent graphic that fills the same space." | aButton | (self wantsRowMenuFor: aScriptOrSlotSymbol) ifFalse: ["Fill the space with sweet nothing, since there is no meaningful menu to offer" aButton _ RectangleMorph new beTransparent extent: (17@20). aButton borderWidth: 0. ^ aButton]. aButton _ IconicButton new labelGraphic: Cursor menu. aButton target: scriptedPlayer; actionSelector: #infoFor:inViewer:; arguments: (Array with:aScriptOrSlotSymbol with: self); color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonDown. aButton setBalloonText: 'Press here to get a menu' translated. ^ aButton! ! !CategoryViewer methodsFor: 'entries' stamp: 'yo 1/14/2005 19:41'! phraseForCommandFrom: aMethodInterface "Answer a phrase for the non-slot-like command represented by aMethodInterface - classic tiles" | aRow resultType cmd names argType argTile selfTile aPhrase balloonTextSelector stat inst aDocString universal tileBearingHelp | aDocString _ aMethodInterface documentation. names _ scriptedPlayer class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ scriptedPlayer isUniversalTiles) ifTrue: [aPhrase _ scriptedPlayer universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new vocabulary: self currentVocabulary. aPhrase setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. (#(bounce: wrap:) includes: cmd) ifTrue: ["help for the embattled bj" argTile setLiteral: #silence translated]. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (scriptedPlayer slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (scriptedPlayer belongsToUniClass and: [scriptedPlayer class includesSelector: cmd]) ifTrue: [aDocString ifNil: [aDocString _ (scriptedPlayer class userScriptForPlayer: scriptedPlayer selector: cmd) documentation]. aDocString ifNil: [balloonTextSelector _ #userScript]]. tileBearingHelp _ universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]. aDocString ifNotNil: [tileBearingHelp setBalloonText: aDocString] ifNil: [balloonTextSelector ifNil: [tileBearingHelp setProperty: #inherentSelector toValue: cmd. balloonTextSelector _ #methodComment]. tileBearingHelp balloonTextSelector: balloonTextSelector]. aPhrase markAsPartsDonor. cmd == #emptyScript ifTrue: [aPhrase setProperty: #newPermanentScript toValue: true. aPhrase setProperty: #newPermanentPlayer toValue: scriptedPlayer. aPhrase submorphs second setBalloonText: 'drag and drop to add a new script' translated]. universal ifFalse: [selfTile _ self tileForSelf. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile]. aRow _ ViewerLine newRow borderWidth: 0; color: self color. aRow elementSymbol: cmd asSymbol. aRow addMorphBack: (ScriptingSystem tryButtonFor: aPhrase). aRow addMorphBack: (Morph new extent: 2@2; beTransparent). aRow addMorphBack: (self infoButtonFor: cmd). aRow addMorphBack: aPhrase. aPhrase on: #mouseEnter send: #addCommandFeedback to: aRow. aPhrase on: #mouseLeave send: #removeHighlightFeedback to: aRow. aPhrase on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (names includes: cmd) ifTrue: [aPhrase userScriptSelector: cmd. cmd numArgs == 0 ifTrue: [aPhrase beTransparent. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. aRow addMorphBack: (stat _ (inst _ scriptedPlayer scriptInstantiationForSelector: cmd) statusControlMorph). inst updateStatusMorph: stat]]. aRow beSticky; disableDragNDrop. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'nk 10/14/2004 11:32'! phraseForVariableFrom: aMethodInterface "Return a structure consisting of tiles and controls and a readout representing a 'variable' belonging to the player, complete with an appropriate readout when indicated. Functions in both universalTiles mode and classic mode. Slightly misnamed in that this path is used for any methodInterface that indicates an interesting resultType." | anArrow slotName getterButton cover inner aRow doc setter tryer universal hotTileForSelf spacer buttonFont | aRow _ ViewerLine newRow color: self color; beSticky; elementSymbol: (slotName _ aMethodInterface selector); wrapCentering: #center; cellPositioning: #leftCenter. (universal _ scriptedPlayer isUniversalTiles) ifFalse: [buttonFont _ Preferences standardEToysFont. aRow addMorphBack: (Morph new color: self color; extent: (((buttonFont widthOfString: '!!') + 8) @ (buttonFont height + 6)); yourself)]. "spacer" aRow addMorphBack: (self infoButtonFor: slotName). aRow addMorphBack: (Morph new color: self color; extent: 0@10). " spacer" universal ifTrue: [inner _ scriptedPlayer universalTilesForGetterOf: aMethodInterface. cover _ Morph new color: Color transparent. cover extent: inner fullBounds extent. (getterButton _ cover copy) addMorph: cover; addMorphBack: inner. cover on: #mouseDown send: #makeUniversalTilesGetter:event:from: to: self withValue: aMethodInterface. aRow addMorphFront: (tryer _ ScriptingSystem tryButtonFor: inner). tryer color: tryer color lighter lighter] ifFalse: [hotTileForSelf _ self tileForSelf bePossessive. hotTileForSelf on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). aRow addMorphBack: hotTileForSelf. aRow addMorphBack: (spacer _ Morph new color: self color; extent: 2@10). spacer on: #mouseEnter send: #addGetterFeedback to: aRow. spacer on: #mouseLeave send: #removeHighlightFeedback to: aRow. spacer on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. spacer on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: aMethodInterface selector with: aMethodInterface resultType). hotTileForSelf on: #mouseEnter send: #addGetterFeedback to: aRow. hotTileForSelf on: #mouseLeave send: #removeHighlightFeedback to: aRow. hotTileForSelf on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. getterButton _ self getterButtonFor: aMethodInterface selector type: aMethodInterface resultType]. aRow addMorphBack: getterButton. getterButton on: #mouseEnter send: #addGetterFeedback to: aRow. getterButton on: #mouseLeave send: #removeHighlightFeedback to: aRow. getterButton on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow. (doc _ aMethodInterface documentation) ifNotNil: [getterButton setBalloonText: doc]. universal ifFalse: [(slotName == #seesColor:) ifTrue: [self addIsOverColorDetailTo: aRow. ^ aRow]. (slotName == #touchesA:) ifTrue: [self addTouchesADetailTo: aRow. ^ aRow]. (slotName == #overlaps: or: [ slotName == #overlapsAny:]) ifTrue: [self addOverlapsDetailTo: aRow. ^ aRow]]. aRow addMorphBack: (AlignmentMorph new beTransparent). "flexible spacer" (setter _ aMethodInterface companionSetterSelector) ifNotNil: [aRow addMorphBack: (Morph new color: self color; extent: 2@10). " spacer" anArrow _ universal ifTrue: [self arrowSetterButton: #newMakeSetterFromInterface:evt:from: args: aMethodInterface] ifFalse: [self arrowSetterButton: #makeSetter:from:forPart: args: (Array with: slotName with: aMethodInterface resultType)]. anArrow beTransparent. universal ifFalse: [anArrow on: #mouseEnter send: #addSetterFeedback to: aRow. anArrow on: #mouseLeave send: #removeHighlightFeedback to: aRow. anArrow on: #mouseLeaveDragging send: #removeHighlightFeedback to: aRow]. aRow addMorphBack: anArrow]. (#(color:sees: playerSeeingColor copy touchesA: overlaps:) includes: slotName) ifFalse: [(universal and: [slotName == #seesColor:]) ifFalse: [aMethodInterface wantsReadoutInViewer ifTrue: [aRow addMorphBack: (self readoutFor: slotName type: aMethodInterface resultType readOnly: setter isNil getSelector: aMethodInterface selector putSelector: setter)]]]. anArrow ifNotNil: [anArrow step]. ^ aRow! ! !CategoryViewer methodsFor: 'entries' stamp: 'sw 7/4/2004 01:09'! readoutFor: partName type: partType readOnly: readOnly getSelector: getSelector putSelector: putSelector "Answer a readout morph for the given part" | readout delta | readout _ (Vocabulary vocabularyForType: partType) updatingTileForTarget: scriptedPlayer partName: partName getter: getSelector setter: putSelector. (partType == #Number) ifTrue: [(delta _ scriptedPlayer arrowDeltaFor: getSelector) = 1 ifFalse: [readout setProperty: #arrowDelta toValue: delta]. scriptedPlayer setFloatPrecisionFor: readout updatingStringMorph]. readout step. ^ readout! ! !CategoryViewer methodsFor: 'entries' stamp: 'nk 10/14/2004 10:54'! wantsRowMenuFor: aSymbol "Answer whether a viewer row for the given symbol should have a menu button on it" | elementType | true ifTrue: [^ true]. "To allow show categories item. So someday this method can be removed, and its sender can stop sending it..." elementType _ scriptedPlayer elementTypeFor: aSymbol vocabulary: self currentVocabulary. (elementType == #systemScript) ifTrue: [^ false]. ((elementType == #systemSlot) and: [#(color:sees: touchesA: overlaps: overlapsAny:) includes: aSymbol]) ifTrue: [^ false]. ^ true! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51'! arrowSetterButton: sel args: argArray | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.' translated. m on: #mouseDown send: sel to: self withValue: argArray. ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'dgd 9/1/2003 13:51'! arrowSetterButtonFor: partName type: partType | m | m _ RectangleMorph new color: (ScriptingSystem colorForType: #command); extent: 24@TileMorph defaultH; borderWidth: 0. m addMorphCentered: (ImageMorph new image: (ScriptingSystem formAtKey: 'Gets')). m setBalloonText: 'drag from here to obtain an assignment phrase.' translated. m on: #mouseDown send: #makeSetter:event:from: to: self withValue: (Array with: partName with: partType). ^ m ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 9/27/2001 04:23'! getterButtonFor: getterSelector type: partType "Answer a classic-tiles getter button for a part of the given name" | m inherent wording | m _ TileMorph new adoptVocabulary: self currentVocabulary. inherent _ Utilities inherentSelectorForGetter: getterSelector. wording _ (scriptedPlayer slotInfo includesKey: inherent) ifTrue: [inherent] ifFalse: [self currentVocabulary tileWordingForSelector: getterSelector]. m setOperator: getterSelector andUseWording: wording. m typeColor: (ScriptingSystem colorForType: partType). m on: #mouseDown send: #makeGetter:event:from: to: self withValue: (Array with: getterSelector with: partType). ^ m! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'nk 10/14/2004 11:32'! getterTilesFor: getterSelector type: aType "Answer classic getter for the given name/type" "aPhrase _ nil, assumed" | selfTile selector aPhrase | (#(#color:sees: #colorSees) includes: getterSelector) ifTrue: [aPhrase := self colorSeesPhrase]. (#(#seesColor: #isOverColor) includes: getterSelector) ifTrue: [aPhrase := self seesColorPhrase]. (#(#overlaps: #overlaps) includes: getterSelector) ifTrue: [aPhrase := self overlapsPhrase]. (#(#overlapsAny: #overlapsAny) includes: getterSelector) ifTrue: [aPhrase := self overlapsAnyPhrase]. (#(#touchesA: #touchesA) includes: getterSelector) ifTrue: [aPhrase := self touchesAPhrase]. aPhrase ifNil: [aPhrase := PhraseTileMorph new setSlotRefOperator: getterSelector asSymbol type: aType]. selfTile := self tileForSelf bePossessive. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile. selector := aPhrase submorphs second. (Vocabulary vocabularyNamed: aType capitalized) ifNotNilDo: [:aVocab | aVocab wantsSuffixArrow ifTrue: [selector addSuffixArrow]]. selector updateLiteralLabel. aPhrase enforceTileColorPolicy. ^aPhrase! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 4/6/2001 00:59'! makeGetter: args event: evt from: aMorph "Hand the user tiles representing a classic getter on the slot represented by aMorph" | tiles | tiles _ self getterTilesFor: args first type: args second. owner ifNotNil: [self primaryHand attachMorph: tiles] ifNil: [^ tiles] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:26'! makeGetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self makeGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'nk 8/29/2004 17:17'! makeSetter: selectorAndTypePair event: evt from: aMorph "Classic tiles: make a Phrase that comprises a setter of a slot, and hand it to the user." | argType m argTile selfTile argValue actualGetter | argType := selectorAndTypePair second. actualGetter := selectorAndTypePair first asSymbol. m := PhraseTileMorph new setAssignmentRoot: (Utilities inherentSelectorForGetter: actualGetter) type: #command rcvrType: #Player argType: argType vocabulary: self currentVocabulary. argValue := self scriptedPlayer perform: selectorAndTypePair first asSymbol. (argValue isPlayerLike) ifTrue: [argTile := argValue tileReferringToSelf] ifFalse: [argTile := ScriptingSystem tileForArgType: argType. (argType == #Number and: [argValue isNumber]) ifTrue: [(scriptedPlayer decimalPlacesForGetter: actualGetter) ifNotNilDo: [:places | (argTile findA: UpdatingStringMorph) decimalPlaces: places]]. argTile setLiteral: argValue; updateLiteralLabel]. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile. selfTile := self tileForSelf bePossessive. selfTile position: m firstSubmorph position. m firstSubmorph addMorph: selfTile. m enforceTileColorPolicy. m openInHand! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! makeSetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self makeSetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'! makeUniversalTilesGetter: aMethodInterface event: evt from: aMorph "Button in viewer performs this to make a universal-tiles getter and attach it to hand." | newTiles | newTiles _ self newGetterTilesFor: scriptedPlayer methodInterface: aMethodInterface. newTiles setProperty: #beScript toValue: true. owner ifNotNil: [ActiveHand attachMorph: newTiles. newTiles align: newTiles topLeft with: evt hand position + (7@14)] ifNil: [^ newTiles] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'nk 10/14/2004 10:53'! newGetterTilesFor: aPlayer methodInterface: aMethodInterface "Return universal tiles for a getter on this property. Record who self is." | ms argTile argArray | ms _ MessageSend receiver: aPlayer selector: aMethodInterface selector arguments: #(). "Handle three idiosyncratic cases..." aMethodInterface selector == #color:sees: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy. ms arguments: argArray]. aMethodInterface selector == #seesColor: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. ms arguments: (Array with: argTile colorSwatch color)]. (#(touchesA: overlaps: overlapsAny:) includes: aMethodInterface selector) ifTrue: [argTile _ ScriptingSystem tileForArgType: #Player. ms arguments: (Array with: argTile actualObject)]. ^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 14:17'! newMakeGetter: arg event: evt from: aMorph "Button in viewer performs this to makea universal-tiles header tile and attach to hand." ^ self makeUniversalTilesGetter: arg event: evt from: aMorph! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 3/28/2001 13:04'! newMakeGetter: arg1 from: arg2 forMethodInterface: arg3 "Button in viewer performs this to make a new style tile and attach to hand. (Reorder the arguments for existing event handlers)" (arg3 isMorph and: [arg3 eventHandler notNil]) ifTrue: [arg3 eventHandler fixReversedValueMessages]. ^ self makeUniversalTilesGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! newMakeGetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self newMakeGetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/17/2001 14:17'! newMakeSetter: aSpec event: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newTilesFor: scriptedPlayer setter: aSpec. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m]. ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'ar 3/18/2001 17:27'! newMakeSetter: arg1 from: arg2 forPart: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self newMakeSetter: arg1 event: arg2 from: arg3! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'RAA 4/6/2001 13:28'! newMakeSetterFromInterface: aMethodInterface evt: evt from: aMorph "Button in viewer performs this to make a new style tile and attach to hand." | m | m _ self newSetterTilesFor: scriptedPlayer methodInterface: aMethodInterface. m setProperty: #beScript toValue: true. owner ifNotNil: [self primaryHand attachMorph: m. m align: m topLeft with: evt hand position + (7@14)] ifNil: [^ m] ! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'tk 9/30/2001 11:20'! newSetterTilesFor: aPlayer methodInterface: aMethodInterface "Return universal tiles for a setter on this property. Record who self is." | ms argValue makeSelfGlobal phrase | argValue _ aPlayer perform: aMethodInterface selector. ms _ MessageSend receiver: aPlayer selector: aMethodInterface companionSetterSelector arguments: (Array with: argValue). makeSelfGlobal _ aPlayer class officialClass ~~ CardPlayer. phrase _ ms asTilesIn: aPlayer class globalNames: makeSelfGlobal. "For CardPlayers, use 'self'. For others, name it, and use its name." makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: aPlayer]. ^ phrase! ! !CategoryViewer methodsFor: 'get/set slots' stamp: 'sw 11/16/2001 14:44'! newTilesFor: aPlayer setter: aSpec | ms argValue | "Return universal tiles for a getter on this property. Record who self is." argValue _ aPlayer perform: (Utilities getterSelectorFor: aSpec second asSymbol). ms _ MessageSend receiver: aPlayer selector: aSpec ninth arguments: (Array with: argValue). ^ ms asTilesIn: aPlayer class globalNames: (aPlayer class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !CategoryViewer methodsFor: 'header pane' stamp: 'sw 8/31/2004 14:01'! addHeaderMorph "Add the header at the top of the viewer, with a control for choosing the category, etc." | header aButton | header _ AlignmentMorph newRow color: self color; wrapCentering: #center; cellPositioning: #leftCenter. aButton _ self tanOButton. header addMorph: aButton. aButton actionSelector: #delete; setBalloonText: 'remove this pane from the screen don''t worry -- nothing will be lost!!.' translated. self maybeAddArrowsTo: header. header beSticky. self addMorph: header. self addNamePaneTo: header. chosenCategorySymbol _ #basic! ! !CategoryViewer methodsFor: 'header pane' stamp: 'nk 7/12/2004 23:15'! addNamePaneTo: header "Add the namePane, which may be a popup or a type-in depending on the type of CategoryViewer" | aButton | namePane := RectangleMorph newSticky color: Color brown veryMuchLighter. namePane borderWidth: 0. aButton := (StringButtonMorph contents: '-----' font: Preferences standardButtonFont) color: Color black. aButton target: self; arguments: Array new; actionSelector: #chooseCategory. aButton actWhen: #buttonDown. namePane addMorph: aButton. aButton position: namePane position. namePane align: namePane topLeft with: bounds topLeft + (50 @ 0). namePane setBalloonText: 'category (click here to choose a different one)' translated. header addMorphBack: namePane. (namePane isKindOf: RectangleMorph) ifTrue: [namePane addDropShadow. namePane shadowColor: Color gray] ! ! !CategoryViewer methodsFor: 'header pane' stamp: 'dgd 9/1/2003 13:47'! maybeAddArrowsTo: header "Maybe add up/down arrows to the header" | wrpr | header addTransparentSpacerOfSize: 5@5. header addUpDownArrowsFor: self. (wrpr _ header submorphs last) submorphs second setBalloonText: 'previous category' translated. wrpr submorphs first setBalloonText: 'next category' translated! ! !CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/22/2002 23:08'! establishContents "Perform any initialization steps that needed to wait until I am installed in my outer viewer"! ! !CategoryViewer methodsFor: 'initialization' stamp: 'dgd 8/16/2004 21:51'! initializeFor: aPlayer categoryChoice: aChoice "Initialize the receiver to be associated with the player and category specified" self listDirection: #topToBottom; hResizing: #spaceFill; vResizing: #spaceFill; borderWidth: 1; beSticky. self color: Color green muchLighter muchLighter. scriptedPlayer _ aPlayer. self addHeaderMorph. self chooseCategoryWhoseTranslatedWordingIs: aChoice ! ! !CategoryViewer methodsFor: 'initialization' stamp: 'sw 8/17/2002 01:23'! setCategorySymbolFrom: aChoice "Set my category symbol" self chosenCategorySymbol: aChoice asSymbol ! ! !CategoryViewer methodsFor: 'macpal' stamp: 'sw 5/4/2001 05:24'! currentVocabulary "Answer the vocabulary currently installed in the viewer. The outer StandardViewer object holds this information." | outerViewer | ^ (outerViewer _ self outerViewer) ifNotNil: [outerViewer currentVocabulary] ifNil: [(self world ifNil: [ActiveWorld]) currentVocabularyFor: scriptedPlayer]! ! !CategoryViewer methodsFor: 'scripting' stamp: 'sw 9/12/2001 22:58'! isTileScriptingElement "Answer whether the receiver is a tile-scripting element" ^ true! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 9/27/2001 13:28'! booleanPhraseForRetrieverOfType: retrieverType retrieverOp: retrieverOp player: aPlayer "Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result" | outerPhrase getterPhrase receiverTile rel finalTile | rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean. outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType. getterPhrase _ PhraseTileMorph new setOperator: retrieverOp type: retrieverType rcvrType: #Player. getterPhrase submorphs last setSlotRefOperator: retrieverOp. getterPhrase submorphs first changeTableLayout. receiverTile _ aPlayer tileToRefer bePossessive. receiverTile position: getterPhrase firstSubmorph position. getterPhrase firstSubmorph addMorph: receiverTile. outerPhrase firstSubmorph addMorph: getterPhrase. finalTile _ ScriptingSystem tileForArgType: retrieverType. "comes with arrows" outerPhrase submorphs last addMorph: finalTile. outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel). ^ outerPhrase! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 3/15/2005 22:33'! booleanPhraseFromPhrase: phrase "Answer, if possible, a boolean-valued phrase derived from the phrase provided" | retrieverOp retrieverTile | (phrase isKindOf: ParameterTile) ifTrue: [^ phrase booleanComparatorPhrase]. phrase isBoolean ifTrue: [^ phrase]. ((scriptedPlayer respondsTo: #costume) and:[scriptedPlayer costume isInWorld not]) ifTrue: [^ Array new]. ((retrieverTile _ phrase submorphs last) isKindOf: TileMorph) ifFalse: [^ phrase]. retrieverOp _ retrieverTile operatorOrExpression. (Vocabulary vocabularyForType: phrase resultType) affordsCoercionToBoolean ifTrue: [^ self booleanPhraseForRetrieverOfType: phrase resultType retrieverOp: retrieverOp player: phrase actualObject]. ^ phrase! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 8/17/2002 01:11'! categoryRestorationInfo "Answer info needed to reincarnate myself" ^ self chosenCategorySymbol! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 8/6/2001 19:42'! limitClass "Answer the receiver's limitClass" | outer | ^ (outer _ self outerViewer) ifNotNil: [outer limitClass] ifNil: [ProtoObject]! ! !CategoryViewer methodsFor: 'support' stamp: 'sw 5/4/2001 05:32'! tileForSelf "Return a tile representing the receiver's viewee" ^ scriptedPlayer tileToRefer ! ! !CautiousModel methodsFor: 'updating' stamp: 'nb 6/17/2003 12:25'! okToChange Preferences cautionBeforeClosing ifFalse: [^ true]. Sensor leftShiftDown ifTrue: [^ true]. Beeper beep. ^ self confirm: 'Warning!! If you answer "yes" here, this window will disappear and its contents will be lost!! Do you really want to do that?' "CautiousModel new okToChange"! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 9/5/2001 13:53'! initialize "Initialize a blank ChangeList. Set the contentsSymbol to reflect whether diffs will initally be shown or not" contentsSymbol _ Preferences diffsInChangeList ifTrue: [self defaultDiffsSymbol] ifFalse: [#source]. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. super initialize! ! !ChangeList methodsFor: 'initialization-release' stamp: 'tpr 10/4/2001 21:58'! openAsMorphName: labelString multiSelect: multiSelect "Open a morphic view for the messageSet, whose label is labelString. The listView may be either single or multiple selection type" | window listHeight listPane | listHeight _ 0.4. window _ (SystemWindow labelled: labelString) model: self. listPane _ multiSelect ifTrue: [PluggableListMorphOfMany on: self list: #list primarySelection: #listIndex changePrimarySelection: #toggleListIndex: listSelection: #listSelectionAt: changeListSelection: #listSelectionAt:put: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])] ifFalse: [PluggableListMorph on: self list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (self showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])]. listPane keystrokeActionSelector: #changeListKey:from:. window addMorph: listPane frame: (0 @ 0 extent: 1 @ listHeight). self addLowerPanesTo: window at: (0 @ listHeight corner: 1 @ 1) with: nil. ^ window openInWorld! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 11/13/2001 08:50'! optionalButtonsView "Answer the a View containing the optional buttons" | view bHeight vWidth first offset previousView bWidth button | vWidth _ 200. bHeight _ self optionalButtonHeight. previousView _ nil. offset _ 0. first _ true. view _ View new model: self; window: (0 @ 0 extent: vWidth @ bHeight). self changeListButtonSpecs do: [:triplet | button _ PluggableButtonView on: self getState: nil action: triplet second. button label: triplet first asParagraph. bWidth _ button label boundingBox width // 2. button window: (offset@0 extent: bWidth@bHeight); borderWidthLeft: 0 right: 1 top: 0 bottom: 0. offset _ offset + bWidth. first ifTrue: [view addSubView: button. first _ false.] ifFalse: [view addSubView: button toRightOf: previousView]. previousView _ button]. button _ PluggableButtonView on: self getState: #showingAnyKindOfDiffs action: #toggleDiffing. button label: 'diffs' asParagraph; window: (offset@0 extent: (vWidth - offset)@bHeight). view addSubView: button toRightOf: previousView. ^ view! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 8/15/2002 22:34'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ true! ! !ChangeList methodsFor: 'scanning' stamp: 'sw 10/19/1999 15:13'! scanFile: aFile from: startPosition to: stopPosition | itemPosition item prevChar | file _ aFile. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. file position: startPosition. 'Scanning ', aFile localName, '...' displayProgressAt: Sensor cursorPoint from: startPosition to: stopPosition during: [:bar | [file position < stopPosition] whileTrue: [bar value: file position. [file atEnd not and: [file peek isSeparator]] whileTrue: [prevChar _ file next]. (file peekFor: $!!) ifTrue: [(prevChar = Character cr or: [prevChar = Character lf]) ifTrue: [self scanCategory]] ifFalse: [itemPosition _ file position. item _ file nextChunk. file skipStyleChunk. item size > 0 ifTrue: [self addItem: (ChangeRecord new file: file position: itemPosition type: #doIt) text: 'do it: ' , (item contractTo: 50)]]]]. listSelections _ Array new: list size withAll: false! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 11:08'! browseAllVersionsOfSelections "Opens a Versions browser on all the currently selected methods, showing each alongside all of their historical versions." | oldSelection aList | oldSelection _ self listIndex. aList _ OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ listIndex _ i. self browseVersions. aList add: i. ]]]. listIndex _ oldSelection. aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'RAA 5/28/2001 11:37'! browseCurrentVersionsOfSelections "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" | aClass aChange aList | aList _ OrderedCollection new. Cursor read showWhile: [ 1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [ aChange _ changeList at: i. (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [ aList add: ( MethodReference new setStandardClass: aClass methodSymbol: aChange methodSelector ) ]]]]. aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. MessageSet openMessageList: aList name: 'Current versions of selected methods in ', file localName! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 10:23'! browseVersions | change class browser | listIndex = 0 ifTrue: [^ nil ]. change _ changeList at: listIndex. ((class _ change methodClass) notNil and: [class includesSelector: change methodSelector]) ifFalse: [ ^nil ]. browser _ super browseVersions. browser ifNotNil: [ browser addedChangeRecord: change ]. ^browser! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 11:11'! changeListMenu: aMenu "Fill aMenu up so that it comprises the primary changelist-browser menu" Smalltalk isMorphic ifTrue: [aMenu addTitle: 'change list'. aMenu addStayUpItemSpecial]. aMenu addList: #( ('fileIn selections' fileInSelections 'import the selected items into the image') ('fileOut selections... ' fileOutSelections 'create a new file containing the selected items') - ('compare to current' compareToCurrentVersion 'open a separate window which shows the text differences between the on-file version and the in-image version.' ) ('toggle diffing (D)' toggleDiffing 'start or stop showing diffs in the code pane.') - ('select conflicts with any changeset' selectAllConflicts 'select methods in the file which also occur in any change-set in the system') ('select conflicts with current changeset' selectConflicts 'select methods in the file which also occur in the current change-set') ('select conflicts with...' selectConflictsWith 'allows you to designate a file or change-set against which to check for code conflicts.') - ('select unchanged methods' selectUnchangedMethods 'select methods in the file whose in-image versions are the same as their in-file counterparts' ) ('select new methods' selectNewMethods 'select methods in the file that do not current occur in the image') ('select methods for this class' selectMethodsForThisClass 'select all methods in the file that belong to the currently-selected class') - ('select all (a)' selectAll 'select all the items in the list') ('deselect all' deselectAll 'deselect all the items in the list') ('invert selections' invertSelections 'select every item that is not currently selected, and deselect every item that *is* currently selected') - ('browse all versions of single selection' browseVersions 'open a version browser showing the versions of the currently selected method') ('browse all versions of selections' browseAllVersionsOfSelections 'open a version browser showing all the versions of all the selected methods') ('browse current versions of selections' browseCurrentVersionsOfSelections 'open a message-list browser showing the current (in-image) counterparts of the selected methods') ('destroy current methods of selections' destroyCurrentCodeOfSelections 'remove (*destroy*) the in-image counterparts of all selected methods') - ('remove doIts' removeDoIts 'remove all items that are doIts rather than methods') ('remove older versions' removeOlderMethodVersions 'remove all but the most recent versions of methods in the list') ('remove up-to-date versions' removeExistingMethodVersions 'remove all items whose code is the same as the counterpart in-image code') ('remove selected items' removeSelections 'remove the selected items from the change-list') ('remove unselected items' removeNonSelections 'remove all the items not currently selected from the change-list')). ^ aMenu ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 5/20/2001 21:18'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change class s1 s2 | listIndex = 0 ifTrue: [^ self]. change _ changeList at: listIndex. ((class _ change methodClass) notNil and: [class includesSelector: change methodSelector]) ifTrue: [s1 _ (class sourceCodeAt: change methodSelector) asString. s2 _ change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: class prettyDiffs: self showingPrettyDiffs)) openLabel: 'Comparison to Current Version'] ifFalse: [self flash]! ! !ChangeList methodsFor: 'menu actions' stamp: 'yo 7/5/2004 20:16'! fileOutSelections | fileName internalStream | fileName _ FillInTheBlank request: 'Enter the base of file name' initialAnswer: 'Filename'. internalStream _ WriteStream on: (String new: 1000). internalStream header; timeStamp. listSelections with: changeList do: [:selected :item | selected ifTrue: [item fileOutOn: internalStream]]. FileStream writeSourceCodeFrom: internalStream baseName: fileName isSt: true useHtml: false. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 8/15/2002 22:35'! optionalButtonRow "Answer a row of buttons to occur in a tool pane" | aRow aButton | aRow _ AlignmentMorph newRow. aRow hResizing: #spaceFill. aRow clipSubmorphs: true. aRow layoutInset: 5@2; cellInset: 3. aRow wrapCentering: #center; cellPositioning: #leftCenter. self changeListButtonSpecs do: [:triplet | aButton _ PluggableButtonMorph on: self getState: nil action: triplet second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; label: triplet first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aButton setBalloonText: triplet third]. aRow addMorphBack: self regularDiffButton. self wantsPrettyDiffOption ifTrue: [aRow addMorphBack: self prettyDiffButton]. ^ aRow! ! !ChangeList methodsFor: 'menu actions' stamp: 'ar 2/24/2001 18:29'! removeExistingMethodVersions "Remove all up to date version of entries from the receiver" | newChangeList newList str keep cls sel | newChangeList _ OrderedCollection new. newList _ OrderedCollection new. changeList with: list do:[:chRec :strNstamp | keep _ true. (cls _ chRec methodClass) ifNotNil:[ str _ chRec string. sel _ cls parserClass new parseSelector: str. keep _ (cls sourceCodeAt: sel ifAbsent:['']) asString ~= str. ]. keep ifTrue:[ newChangeList add: chRec. newList add: strNstamp]]. newChangeList size < changeList size ifTrue: [changeList _ newChangeList. list _ newList. listIndex _ 0. listSelections _ Array new: list size withAll: false]. self changed: #list! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 6/6/2001 12:54'! selectAllConflicts "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented." | aClass aChange | Cursor read showWhile: [1 to: changeList size do: [:i | aChange _ changeList at: i. listSelections at: i put: (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aChange methodSelector]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'sd 5/23/2003 14:24'! selectConflicts "Selects all method definitions for which there is ALSO an entry in changes" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: (change type = #method and: [(class _ change methodClass) notNil and: [(ChangeSet current atSelector: change methodSelector class: class) ~~ #none]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'di 4/6/2001 09:03'! selectConflictsWith "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList chosen by the user. 4/11/96 tk" | aStream all index | aStream _ WriteStream on: (String new: 200). (all _ ChangeSorter allChangeSets copy) do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. ChangeList allSubInstancesDo: [:sel | aStream nextPutAll: (sel file name); cr. all addLast: sel]. aStream skip: -1. index _ (PopUpMenu labels: aStream contents) startUp. index > 0 ifTrue: [ self selectConflicts: (all at: index)]. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 12/3/2002 22:27'! selectNewMethods "Selects all method definitions for which there is no counterpart method in the current image" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: ((change type = #method and: [((class _ change methodClass) isNil) or: [(class includesSelector: change methodSelector) not]]))]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'nk 1/7/2004 09:16'! selectUnchangedMethods "Selects all method definitions for which there is already a method in the current image, whose source is exactly the same. 9/18/96 sw" | change class | Cursor read showWhile: [1 to: changeList size do: [:i | change _ changeList at: i. listSelections at: i put: ((change type = #method and: [(class _ change methodClass) notNil]) and: [(class includesSelector: change methodSelector) and: [change string withBlanksCondensed = (class sourceCodeAt: change methodSelector) asString withBlanksCondensed ]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 6/18/2001 10:44'! annotation "Answer the string to be shown in an annotation pane. Make plain that the annotation is associated with the current in-image version of the code, not of the selected disk-based version, and if the corresponding method is missing from the in-image version, mention that fact." | annot aChange aClass | annot _ super annotation. annot asString = '------' ifTrue: [^ annot]. ^ ((aChange _ self currentChange) notNil and: [aChange methodSelector notNil]) ifFalse: [annot] ifTrue: [((aClass _ aChange methodClass) isNil or: [(aClass includesSelector: aChange methodSelector) not]) ifTrue: [aChange methodClassName, ' >> ', aChange methodSelector, ' is not present in the current image.'] ifFalse: ['current version: ', annot]]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 9/5/2001 13:52'! contents "Answer the contents string, obeying diffing directives if needed" ^ self showingAnyKindOfDiffs ifFalse: [self undiffedContents] ifTrue: [self showsVersions ifTrue: [self diffedVersionContents] ifFalse: [self contentsDiffedFromCurrent]]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 5/19/2001 10:59'! contentsDiffedFromCurrent "Answer the contents diffed forward from current (in-memory) method version" | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange _ changeList at: listIndex. ^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) ifTrue: [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector prettyDiffs: self showingPrettyDiffs] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 11/13/2001 09:12'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ self sourceAndDiffsQuintsOnly! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 6/7/2001 23:54'! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change _ changeList at: listIndex. later _ change text. class _ change methodClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ later]. earlier _ (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ChangeList methodsFor: 'viewing access' stamp: 'NS 1/28/2004 11:18'! restoreDeletedMethod "If lostMethodPointer is not nil, then this is a version browser for a method that has been removed. In this case we want to establish a sourceCode link to prior versions. We do this by installing a dummy method with the correct source code pointer prior to installing this version." | dummyMethod class selector | dummyMethod _ CompiledMethod toReturnSelf setSourcePointer: lostMethodPointer. class _ (changeList at: listIndex) methodClass. selector _ (changeList at: listIndex) methodSelector. class addSelectorSilently: selector withMethod: dummyMethod. (changeList at: listIndex) fileIn. "IF for some reason, the dummy remains, remove it, but (N.B.!!) we might not get control back if the compile (fileIn above) fails." (class compiledMethodAt: selector) == dummyMethod ifTrue: [class basicRemoveSelector: selector]. ^ true! ! !ChangeList methodsFor: 'viewing access' stamp: 'nk 2/26/2004 13:50'! selectedClass ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! ! !ChangeList class methodsFor: 'public access' stamp: 'HK 4/18/2002 15:02'! browseRecent: charCount "ChangeList browseRecent: 5000" "Opens a changeList on the end of the changes log file" ^ self browseRecent: charCount on: (SourceFiles at: 2) ! ! !ChangeList class methodsFor: 'public access' stamp: 'yo 8/17/2004 09:52'! browseRecent: charCount on: origChangesFile "Opens a changeList on the end of the specified changes log file" | changeList end changesFile | changesFile _ origChangesFile readOnlyCopy. changesFile setConverterForCode. end _ changesFile size. Cursor read showWhile: [changeList _ self new scanFile: changesFile from: (0 max: end - charCount) to: end]. changesFile close. self open: changeList name: 'Recent changes' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:10'! browseRecentLog "ChangeList browseRecentLog" "Prompt with a menu of how far back to go to browse the current image's changes log file" ^ self browseRecentLogOn: (SourceFiles at: 2) startingFrom: SmalltalkImage current lastQuitLogPosition! ! !ChangeList class methodsFor: 'public access' stamp: 'nk 7/8/2003 13:56'! browseRecentLogOn: origChangesFile "figure out where the last snapshot or quit was, then browse the recent entries." | end done block pos chunk changesFile positions prevBlock | changesFile _ origChangesFile readOnlyCopy. positions _ SortedCollection new. end _ changesFile size. prevBlock _ end. block _ end - 1024 max: 0. done _ false. [done or: [positions size > 0]] whileFalse: [changesFile position: block. "ignore first fragment" changesFile nextChunk. [changesFile position < prevBlock] whileTrue: [pos _ changesFile position. chunk _ changesFile nextChunk. ((chunk indexOfSubCollection: '----' startingAt: 1) = 1) ifTrue: [ ({ '----QUIT'. '----SNAPSHOT' } anySatisfy: [ :str | chunk beginsWith: str ]) ifTrue: [positions add: pos]]]. block = 0 ifTrue: [done _ true] ifFalse: [prevBlock _ block. block _ block - 1024 max: 0]]. changesFile close. positions isEmpty ifTrue: [self inform: 'File ' , changesFile name , ' does not appear to be a changes file'] ifFalse: [self browseRecentLogOn: origChangesFile startingFrom: positions last]! ! !ChangeList class methodsFor: 'public access' stamp: 'yo 8/17/2004 18:49'! browseRecentLogOn: origChangesFile startingFrom: initialPos "Prompt with a menu of how far back to go when browsing a changes file." | end banners positions pos chunk i changesFile | changesFile _ origChangesFile readOnlyCopy. banners _ OrderedCollection new. positions _ OrderedCollection new. end _ changesFile size. changesFile setConverterForCode. pos _ initialPos. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk _ changesFile nextChunk. i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i - 2). pos _ Number readFrom: (chunk copyFrom: i + 13 to: chunk size)] ifFalse: [pos _ 0]]. changesFile close. banners size == 0 ifTrue: [^ self inform: 'this image has never been saved since changes were compressed']. pos _ (SelectionMenu labelList: banners selections: positions) startUpWithCaption: 'Browse as far back as...'. pos == nil ifTrue: [^ self]. self browseRecent: end - pos on: origChangesFile! ! !ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25'! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep] ! ! !ChangeList class methodsFor: 'public access' stamp: 'yo 8/17/2004 09:59'! browseStream: changesFile "Opens a changeList on a fileStream" | changeList charCount | changesFile readOnly. changesFile setConverterForCode. charCount _ changesFile size. charCount > 1000000 ifTrue: [(self confirm: 'The file ', changesFile name , ' is really long (' , charCount printString , ' characters). Would you prefer to view only the last million characters?') ifTrue: [charCount _ 1000000]]. "changesFile setEncoderForSourceCodeNamed: changesFile name." Cursor read showWhile: [changeList _ self new scanFile: changesFile from: changesFile size-charCount to: changesFile size]. changesFile close. self open: changeList name: changesFile localName , ' log' multiSelect: true! ! !ChangeList class methodsFor: 'public access' stamp: 'sd 11/16/2003 14:11'! getRecentLocatorWithPrompt: aPrompt "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" "ChangeList getRecentPosition" | end changesFile banners positions pos chunk i | changesFile _ (SourceFiles at: 2) readOnlyCopy. banners _ OrderedCollection new. positions _ OrderedCollection new. end _ changesFile size. pos _ SmalltalkImage current lastQuitLogPosition. [pos = 0 or: [banners size > 20]] whileFalse: [changesFile position: pos. chunk _ changesFile nextChunk. i _ chunk indexOfSubCollection: 'priorSource: ' startingAt: 1. i > 0 ifTrue: [positions addLast: pos. banners addLast: (chunk copyFrom: 5 to: i-2). pos _ Number readFrom: (chunk copyFrom: i+13 to: chunk size)] ifFalse: [pos _ 0]]. changesFile close. pos _ (SelectionMenu labelList: banners selections: positions) startUpWithCaption: aPrompt. pos == nil ifTrue: [^ nil]. ^ end - pos! ! !ChangeList class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 21:02'! open: aChangeList name: aString multiSelect: multiSelect "Create a standard system view for the messageSet, whose label is aString. The listView may be either single or multiple selection type" | topView listHeight annoHeight optButtonHeight codeHeight aListView underPane annotationPane buttonsView aBrowserCodeView | Smalltalk isMorphic ifTrue: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect]. listHeight _ 70. annoHeight _ 10. optButtonHeight _ aChangeList optionalButtonHeight. codeHeight _ 110. topView _ (StandardSystemView new) model: aChangeList; label: aString; minimumSize: 200 @ 120; borderWidth: 1. aListView _ (multiSelect ifTrue: [PluggableListViewOfMany on: aChangeList list: #list primarySelection: #listIndex changePrimarySelection: #toggleListIndex: listSelection: #listSelectionAt: changeListSelection: #listSelectionAt:put: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])] ifFalse: [PluggableListView on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:])]). aListView window: (0 @ 0 extent: 200 @ listHeight). topView addSubView: aListView. underPane _ aListView. aChangeList wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: aChangeList text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0 @ 0 extent: 200 @ 10). topView addSubView: annotationPane below: underPane. underPane _ annotationPane. codeHeight _ codeHeight - annoHeight]. aChangeList wantsOptionalButtons ifTrue: [buttonsView _ aChangeList optionalButtonsView. buttonsView borderWidth: 1. topView addSubView: buttonsView below: underPane. underPane _ buttonsView. codeHeight _ codeHeight - optButtonHeight]. aBrowserCodeView _ PluggableTextView on: aChangeList text: #contents accept: #contents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. aBrowserCodeView controller: ReadOnlyTextController new; window: (0 @ 0 extent: 200 @ codeHeight). topView addSubView: aBrowserCodeView below: underPane. topView controller open.! ! !ChangeList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:07'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Change List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that presents a list of all the changes found in an external file.'! ! !ChangeList class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 18:14'! initialize FileList registerFileReader: self! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'md 10/22/2003 16:13'! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [ChangeList browseStream: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 8/31/2004 08:59'! browseCompressedChangesFile: fullName "Browse the selected file in fileIn format." | zipped unzipped stream | fullName ifNil: [^Beeper beep]. stream := FileStream readOnlyFileNamed: fullName. stream converter: Latin1TextConverter new. zipped := GZipReadStream on: stream. unzipped := zipped contents asString. stream := (MultiByteBinaryOrTextStream with: unzipped) reset. ChangeList browseStream: stream! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:48'! fileReaderServicesForFile: fullName suffix: suffix | services | services _ OrderedCollection new. (FileStream isSourceFileSuffix: suffix) | (suffix = '*') ifTrue: [ services add: self serviceBrowseChangeFile ]. (suffix = 'changes') | (suffix = '*') ifTrue: [ services add: self serviceBrowseDotChangesFile ]. (fullName asLowercase endsWith: '.cs.gz') | (suffix = '*') ifTrue: [ services add: self serviceBrowseCompressedChangeFile ]. ^services! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 4/29/2004 10:35'! serviceBrowseChangeFile "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseStream: description: 'open a changelist tool on this file' buttonLabel: 'changes') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:03'! serviceBrowseCompressedChangeFile "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self label: 'changelist browser' selector: #browseCompressedChangesFile: description: 'open a changelist tool on this file' buttonLabel: 'changes'! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'sw 7/4/2002 18:37'! serviceBrowseDotChangesFile "Answer a service for opening a changelist browser on the tail end of a .changes file" ^ SimpleServiceEntry provider: self label: 'recent changes in file' selector: #browseRecentLogOnPath: description: 'open a changelist tool on recent changes in file' buttonLabel: 'recent changes'! ! !ChangeList class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 12:04'! services "Answer potential file services associated with this class" ^ { self serviceBrowseChangeFile. self serviceBrowseDotChangesFile. self serviceBrowseCompressedChangeFile }! ! !ChangeList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !ChangeListForProjects methodsFor: 'contents' stamp: 'sw 9/5/2001 15:25'! contents ^ self showingAnyKindOfDiffs ifFalse: [self undiffedContents] ifTrue: [self currentDiffedFromContents] "Current is writing over one in list. Show how I would change it"! ! !ChangeListForProjects methodsFor: 'contents' stamp: 'sw 5/19/2001 11:06'! currentDiffedFromContents "Answer the current in-memory method diffed from the current contents" | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange _ changeList at: listIndex. ^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) ifTrue: [TextDiffBuilder buildDisplayPatchFrom: aChange text to: (aClass sourceCodeAt: aChange methodSelector) inClass: aClass prettyDiffs: self showingPrettyDiffs] ifFalse: [(changeList at: listIndex) text]! ! !ChangeListForProjects commentStamp: '' prior: 0! A ChangeList that looks at the changes in a revokable project. This class has no users at present.! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/1/2003 18:27'! fileIndex ^ (SourceFiles collect: [ :sf | sf name]) indexOf: file name ifAbsent: [^ nil]. ! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'! fileName ^(file ifNotNil: [ file name ]) ifNil: [ '' ]! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 10/20/2002 02:53'! fileOutOn: aFileStream "File the receiver out on the given file stream" | aString | type == #method ifTrue: [aFileStream nextPut: $!!. aString _ class asString , (meta ifTrue: [' class methodsFor: '] ifFalse: [' methodsFor: ']) , category asString printString. stamp ifNotNil: [aString _ aString, ' stamp: ''', stamp, '''']. aFileStream nextChunkPut: aString. aFileStream cr]. type == #preamble ifTrue: [aFileStream nextPut: $!!]. type == #classComment ifTrue: [aFileStream nextPut: $!!. aFileStream nextChunkPut: class asString, ' commentStamp: ', stamp storeString. aFileStream cr]. aFileStream nextChunkPut: self string. type == #method ifTrue: [aFileStream nextChunkPut: ' ']. aFileStream cr! ! !ChangeRecord methodsFor: 'access' stamp: 'dew 9/7/2001 00:27'! originalChangeSetForSelector: methodSelector "Returns the original changeset which contained this method version. If it is contained in the .sources file, return #sources. If it is in neither (e.g. its changeset was deleted), return nil. (The selector is passed in purely as an optimization.)" | likelyChangeSets originalChangeSet | (file localName findTokens: '.') last = 'sources' ifTrue: [^ #sources]. likelyChangeSets _ ChangeSorter allChangeSets select: [:cs | (cs atSelector: methodSelector class: self methodClass) ~~ #none]. originalChangeSet _ likelyChangeSets detect: [:cs | cs containsMethodAtPosition: position] ifNone: [nil]. ^ originalChangeSet "(still need to check for sources file)"! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'! position ^ position! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 13:33'! prior | currFile preamble prevPos tokens prevFileIndex | currFile _ file readOnlyCopy. currFile position: (0 max: position - 150). [currFile position < (position - 1)] whileTrue: [preamble _ currFile nextChunk]. currFile close. prevPos _ nil. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens _ Scanner new scanTokens: preamble] ifFalse: [tokens _ Array new]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size - 5) == #methodsFor:]) ifTrue: [ (tokens at: tokens size - 3) == #stamp: ifTrue: [ prevPos _ tokens last. prevFileIndex _ SourceFiles fileIndexFromSourcePointer: prevPos. prevPos _ SourceFiles filePositionFromSourcePointer: prevPos] ifFalse: [ prevPos _ tokens at: tokens size - 2. prevFileIndex _ tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos _ nil]]. prevPos ifNil: [^ nil]. ^ {prevFileIndex. prevPos. SourceFiles sourcePointerFromFileIndex: prevFileIndex andPosition: prevPos}! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 11/25/2003 09:44'! timeStamp "Answer a TimeStamp that corresponds to my (text) stamp" | tokens date time | tokens := self stamp findTokens: Character separators. ^ tokens size > 2 ifTrue: [[date := Date fromString: (tokens at: tokens size - 1). time := Time fromString: tokens last. TimeStamp date: date time: time] on: Error do: [:ex | ex return: (TimeStamp fromSeconds: 0)]] ifFalse: [TimeStamp fromSeconds: 0]! ! !ChangeRecord methodsFor: 'initialization' stamp: 'nk 11/26/2002 12:07'! fileIn "File the receiver in. If I represent a method or a class-comment, file the method in and make a note of it in the recent-submissions list; if I represent a do-it, then, well, do it." | methodClass s aSelector | Cursor read showWhile: [(methodClass _ self methodClass) notNil ifTrue: [methodClass compile: self text classified: category withStamp: stamp notifying: nil. (aSelector _ self methodSelector) ifNotNil: [Utilities noteMethodSubmission: aSelector forClass: methodClass]]. (type == #doIt) ifTrue: [((s _ self string) beginsWith: '----') ifFalse: [Compiler evaluate: s]]. (type == #classComment) ifTrue: [ | cls | (cls _ Smalltalk at: class asSymbol) comment: self text stamp: stamp. Utilities noteMethodSubmission: #Comment forClass: cls ]]! ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/6/2001 09:40'! initialize "Initialize the receiver to be empty." name ifNil: [^ self error: 'All changeSets must be registered, as in ChangeSorter newChangeSet']. revertable _ false. self clear. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 1/19/2004 18:30'! changeClass: class from: oldClass "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." class wantsChangeSetLogging ifFalse: [^ self]. isolationSet ifNotNil: ["If there is an isolation layer above me, inform it as well." isolationSet changeClass: class from: oldClass]. class isMeta ifFalse: [self atClass: class add: #change] "normal" ifTrue: [((self classChangeAt: class theNonMetaClass name) includes: #add) ifTrue: [self atClass: class add: #add] "When a class is defined, the metaclass is not recorded, even though it was added. A further change is really just part of the original add." ifFalse: [self atClass: class add: #change]]. self addCoherency: class name. (self changeRecorderFor: class) notePriorDefinition: oldClass. self noteClassStructure: oldClass! ! !ChangeSet methodsFor: 'change logging' stamp: 'NS 4/12/2004 22:44'! event: anEvent "Hook for SystemChangeNotifier" (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self noteRemovalOf: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self addClass: anEvent item]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [anEvent anyChanges ifTrue: [self changeClass: anEvent item from: anEvent oldItem]]. (anEvent isCommented and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self commentClass: anEvent item]. (anEvent isAdded and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: nil]. (anEvent isModified and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self noteNewMethod: anEvent item forClass: anEvent itemClass selector: anEvent itemSelector priorMethod: anEvent oldItem]. (anEvent isRemoved and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self removeSelector: anEvent itemSelector class: anEvent itemClass priorMethod: anEvent item lastMethodInfo: {anEvent item sourcePointer. anEvent itemProtocol}]. (anEvent isRenamed and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self renameClass: anEvent item as: anEvent newName]. (anEvent isReorganized and: [anEvent itemKind = SystemChangeNotifier classKind]) ifTrue: [self reorganizeClass: anEvent item]. (anEvent isRecategorized and: [anEvent itemKind = SystemChangeNotifier methodKind]) ifTrue: [self reorganizeClass: anEvent itemClass].! ! !ChangeSet methodsFor: 'change logging' stamp: 'tk 6/8/2001 09:27'! renameClass: class as: newName "Include indication that a class has been renamed." | recorder | isolationSet ifNotNil: ["If there is an isolation layer above me, inform it as well." isolationSet renameClass: class as: newName]. (recorder _ self changeRecorderFor: class) noteChangeType: #rename; noteNewName: newName asSymbol. "store under new name (metaclass too)" changeRecords at: newName put: recorder. changeRecords removeKey: class name. self noteClassStructure: class. recorder _ changeRecords at: class class name ifAbsent: [^ nil]. changeRecords at: (newName, ' class') put: recorder. changeRecords removeKey: class class name. recorder noteNewName: newName , ' class'! ! !ChangeSet methodsFor: 'accessing' stamp: 'BJP 4/24/2001 00:23'! author | author | self assurePreambleExists. author _ self preambleString lineNumber: 3. author _ author copyFrom: 8 to: author size. "Strip the 'Author:' prefix. Ugly ugly." ^author withBlanksTrimmed. ! ! !ChangeSet methodsFor: 'accessing' stamp: 'gm 2/16/2003 20:39'! editPostscript "edit the receiver's postscript, in a separate window. " | deps found | self assurePostscriptExists. deps := postscript dependents select: [:m | (m isSystemWindow) or: [m isKindOf: StandardSystemView]]. deps size > 0 ifTrue: [Smalltalk isMorphic ifTrue: [found := deps detect: [:obj | obj isSystemWindow and: [obj world == self currentWorld]] ifNone: [nil]. found ifNotNil: [^found activate]] ifFalse: [found := deps detect: [:obj | (obj isKindOf: StandardSystemView) and: [ScheduledControllers scheduledControllers includes: obj controller]] ifNone: [nil]. found ifNotNil: [^ScheduledControllers activateController: found controller]]. self inform: 'Caution -- there' , (deps size isOrAreStringWith: 'other window') , ' already open on this postscript elsewhere']. postscript openLabel: 'Postscript for ChangeSet named ' , name! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 8/10/2002 22:21'! containsMethodAtPosition: aFilePosition "Answer whether the receiver contains the method logged at the given file position" "class: aClassSymbol" "(need class parameter to speed up?)" "<- dew 9/6/2001" changeRecords values do: [:classChangeRecord | classChangeRecord methodChanges values do: [:methodChangeRecord | | changeType | changeType _ methodChangeRecord changeType. ((changeType == #add or: [changeType == #change]) and: [methodChangeRecord currentMethod notNil and: [methodChangeRecord currentMethod filePosition = aFilePosition]]) ifTrue: [^ true]]]. ^ false! ! !ChangeSet methodsFor: 'testing' stamp: 'nk 7/2/2003 10:47'! methodsWithoutClassifications "Return a collection representing methods in the receiver which have not been categorized" | slips notClassified aSelector | notClassified _ {'as yet unclassified' asSymbol. #all}. slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (aClass selectors includes: (aSelector _ mAssoc key)) ifTrue: [(notClassified includes: (aClass organization categoryOfElement: aSelector)) ifTrue: [slips add: aClass name , ' ' , aSelector]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutClassifications) name: 'unclassified methods'"! ! !ChangeSet methodsFor: 'testing' stamp: 'sd 5/23/2003 14:24'! okayToRemoveInforming: aBoolean "Answer whether it is okay to remove the receiver. If aBoolean is true, inform the receiver if it is not okay" | aName | aName _ self name. self == self class current ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it is the current change set.']. ^ false]. self belongsToAProject ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it belongs to a project.']. ^ false]. ^ true ! ! !ChangeSet methodsFor: 'converting' stamp: 'tk 11/26/2004 05:56'! convertToCurrentVersion: varDict refStream: smartRefStrm "major change - 4/4/2000" | newish | varDict at: 'classChanges' ifPresent: [ :x | newish _ self convertApril2000: varDict using: smartRefStrm. newish == self ifFalse: [^ newish]. ]. ^super convertToCurrentVersion: varDict refStream: smartRefStrm. ! ! !ChangeSet methodsFor: 'method changes' stamp: 'sd 4/16/2003 09:15'! browseMessagesWithPriorVersions "Open a message list browser on the new and changed methods in the receiver which have at least one prior version. 6/28/96 sw" | aList | aList _ self messageListForChangesWhich: [ :aClass :aSelector | (VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1 ] ifNone: [^self inform: 'None!!']. self systemNavigation browseMessageList: aList name: self name, ' methods that have prior versions'! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 6/26/2001 12:15'! changedMessageList "Used by a message set browser to access the list view information." | messageList classNameInFull classNameInParts | messageList _ OrderedCollection new. changeRecords associationsDo: [:clAssoc | classNameInFull _ clAssoc key asString. classNameInParts _ classNameInFull findTokens: ' '. (clAssoc value allChangeTypes includes: #comment) ifTrue: [messageList add: (MethodReference new setClassSymbol: classNameInParts first asSymbol classIsMeta: false methodSymbol: #Comment stringVersion: classNameInFull, ' Comment')]. clAssoc value methodChangeTypes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [messageList add: (MethodReference new setClassSymbol: classNameInParts first asSymbol classIsMeta: classNameInParts size > 1 methodSymbol: mAssoc key stringVersion: classNameInFull, ' ' , mAssoc key)]]]. ^ messageList asSortedArray! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 4/19/2001 19:45'! hasAnyChangeForSelector: aSelector "Answer whether the receiver has any change under the given selector, whether it be add, change, or remove, for any class" changeRecords do: [:aRecord | (aRecord changedSelectors includes: aSelector) ifTrue: [^ true]]. ^ false! ! !ChangeSet methodsFor: 'method changes' stamp: 'RAA 5/28/2001 12:05'! messageListForChangesWhich: aBlock ifNone: ifEmptyBlock | answer | answer _ self changedMessageListAugmented select: [ :each | aBlock value: each actualClass value: each methodSymbol ]. answer isEmpty ifTrue: [^ifEmptyBlock value]. ^answer ! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/26/2004 09:46'! commentClass: class "Include indication that a class comment has been changed." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #comment! ! !ChangeSet methodsFor: 'class changes' stamp: 'nk 6/26/2002 12:30'! containsClass: aClass ^ self changedClasses includes: aClass! ! !ChangeSet methodsFor: 'class changes' stamp: 'NS 1/19/2004 17:49'! noteRemovalOf: class "The class is about to be removed from the system. Adjust the receiver to reflect that fact." class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteChangeType: #remove fromClass: class. changeRecords removeKey: class class name ifAbsent: [].! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 3/30/2002 09:13'! methodsWithAnyInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one, even historically" | slips method aTimeStamp | slips _ Set new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [ :mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [ (aClass changeRecordsAt: mAssoc key) do: [ :chg | aTimeStamp _ chg stamp. (aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]]. ^ slips! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'! methodsWithInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one" | slips method aTimeStamp | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [((aTimeStamp _ Utilities timeStampForMethod: method) notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithInitialsOtherThan: 'sw') name: 'authoring problems'"! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nk 7/2/2003 10:47'! methodsWithoutComments "Return a collection representing methods in the receiver which have no precode comments" | slips | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [(aClass selectors includes: mAssoc key) ifTrue: [(aClass firstPrecodeCommentFor: mAssoc key) isEmptyOrNil ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips "Smalltalk browseMessageList: (ChangeSet current methodsWithoutComments) name: 'methods lacking comments'"! ! !ChangeSet methodsFor: 'moving changes' stamp: 'yo 8/30/2002 13:59'! removeClassChanges: class "Remove all memory of changes associated with this class" | cname | (class isString) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. changeRecords removeKey: cname ifAbsent: []. self noteClassForgotten: cname.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 20:28'! askAddedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly added inst vars need to be non-nil" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. newStruct do: [:instVarName | (oldStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ PopUpMenu withCaption: 'These instance variables were added. When an old project comes in, newly added instance variables will have the value nil. Click on items to remove them from the list. Click on any for which nil is an OK value.' chooseFrom: pairList, #('all of these need a non-nil value' 'all of these are OK with a nil value'). (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 20:29'! askRemovedInstVars: classList | pairList pairClasses index pls newStruct oldStruct | "Ask the author whether these newly removed inst vars need to have their info saved" pairList _ OrderedCollection new. pairClasses _ OrderedCollection new. "Class version numbers: If it must change, something big happened. Do need a conversion method then. Ignore them here." classList do: [:cls | newStruct _ (cls allInstVarNames). oldStruct _ (structures at: cls name ifAbsent: [#(0), newStruct]) allButFirst. oldStruct do: [:instVarName | (newStruct includes: instVarName) ifFalse: [ pairList add: cls name, ' ', instVarName. pairClasses add: cls]]]. pairList isEmpty ifTrue: [^ #()]. [index _ PopUpMenu withCaption: 'These instance variables were removed. When an old project comes in, instance variables that have been removed will lose their contents. Click on items to remove them from the list. Click on any whose value is unimportant and need not be saved.' chooseFrom: pairList, #('all of these need a conversion method' 'all of these have old values that can be erased'). (index <= (pls _ pairList size)) & (index > 0) ifTrue: [ pairList removeAt: index. pairClasses removeAt: index]. index = (pls + 2) ifTrue: ["all are OK" ^ #()]. pairList isEmpty | (index = (pls + 1)) "all need conversion, exit"] whileFalse. ^ pairClasses asSet asArray "non redundant"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'tk 6/8/2001 11:12'! askRenames: renamed addTo: msgSet using: smart | list rec ans oldStruct newStruct | "Go through the renamed classes. Ask the user if it could be in a project. Add a method in SmartRefStream, and a conversion method in the new class." list _ OrderedCollection new. renamed do: [:cls | rec _ changeRecords at: cls name. rec priorName ifNotNil: [ ans _ PopUpMenu withCaption: 'You renamed class ', rec priorName, ' to be ', rec thisName, '.\Could an instance of ', rec priorName, ' be in a project on someone''s disk?' chooseFrom: #('Yes, write code to convert those instances' 'No, no instances are in projects'). ans = 1 ifTrue: [ oldStruct _ structures at: rec priorName ifAbsent: [nil]. newStruct _ (Array with: cls classVersion), (cls allInstVarNames). oldStruct ifNotNil: [ smart writeConversionMethodIn: cls fromInstVars: oldStruct to: newStruct renamedFrom: rec priorName. smart writeClassRename: cls name was: rec priorName. list add: cls name, ' convertToCurrentVersion:refStream:']] ifFalse: [structures removeKey: rec priorName ifAbsent: []]]]. list isEmpty ifTrue: [^ msgSet]. msgSet messageList ifNil: [msgSet initializeMessageList: list] ifNotNil: [list do: [:item | msgSet addItem: item]]. ^ msgSet! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'ls 10/21/2001 21:09'! buildMessageForMailOutWithUser: userName | message compressBuffer compressStream data compressedStream compressTarget | "prepare the message" message := MailMessage empty. message setField: 'from' toString: userName. message setField: 'to' toString: 'squeak-dev@lists.squeakfoundation.org'. message setField: 'subject' toString: (self chooseSubjectPrefixForEmail, name). message body: (MIMEDocument contentType: 'text/plain' content: (String streamContents: [ :str | str nextPutAll: 'from preamble:'; cr; cr. self fileOutPreambleOn: str ])). "Prepare the gzipped data" data _ WriteStream on: String new. data header; timeStamp. self fileOutPreambleOn: data. self fileOutOn: data. self fileOutPostscriptOn: data. data trailer. data _ ReadStream on: data contents. compressBuffer _ ByteArray new: 1000. compressStream _ GZipWriteStream on: (compressTarget _ WriteStream on: (ByteArray new: 1000)). [data atEnd] whileFalse: [compressStream nextPutAll: (data nextInto: compressBuffer)]. compressStream close. compressedStream _ ReadStream on: compressTarget contents asString. message addAttachmentFrom: compressedStream withName: (name, '.cs.gz'). ^ message! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:15'! checkForAlienAuthorship "Check to see if there are any methods in the receiver that have author initials other than that of the current author, and open a browser on all found" | aList initials | (initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. (aList _ self methodsWithInitialsOtherThan: initials) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have authoring stamps which start with "', initials, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', initials, '"']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'! checkForAnyAlienAuthorship "Check to see if there are any versions of any methods in the receiver that have author initials other than that of the current author, and open a browser on all found" | aList initials | (initials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. (aList _ self methodsWithAnyInitialsOtherThan: initials) size > 0 ifFalse: [^ self inform: 'All versions of all methods in "', self name, '" have authoring stamps which start with "', initials, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', initials, '"']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 09:01'! checkForConversionMethods "See if any conversion methods are needed" | oldStruct newStruct tell choice list need sel smart restore renamed listAdd listDrop msgSet rec nn | Preferences conversionMethodsAtFileOut ifFalse: [^ self]. "Check preference" structures ifNil: [^ self]. list _ OrderedCollection new. renamed _ OrderedCollection new. self changedClasses do: [:class | need _ (self atClass: class includes: #new) not. need ifTrue: ["Renamed classes." (self atClass: class includes: #rename) ifTrue: [ rec _ changeRecords at: class name. rec priorName ifNotNil: [ (structures includesKey: rec priorName) ifTrue: [ renamed add: class. need _ false]]]]. need ifTrue: [need _ (self atClass: class includes: #change)]. need ifTrue: [oldStruct _ structures at: class name ifAbsent: [need _ false. #()]]. need ifTrue: [ newStruct _ (Array with: class classVersion), (class allInstVarNames). need _ (oldStruct ~= newStruct)]. need ifTrue: [sel _ #convertToCurrentVersion:refStream:. (#(add change) includes: (self atSelector: sel class: class)) ifFalse: [ list add: class]]. ]. list isEmpty & renamed isEmpty ifTrue: [^ self]. "Ask user if want to do this" tell _ 'If there might be instances of ', (list asArray, renamed asArray) printString, '\in a project (.pr file) on someone''s disk, \please ask to write a conversion method.\' withCRs, 'After you edit the conversion method, you''ll need to fileOut again.\' withCRs, 'The preference conversionMethodsAtFileOut in category "fileout" controls this feature.'. choice _ (PopUpMenu labels: 'Write a conversion method by editing a prototype These classes are not used in any object file. fileOut my changes now. I''m too busy. fileOut my changes now. Don''t ever ask again. fileOut my changes now.') startUpWithCaption: tell. choice = 4 ifTrue: [Preferences disable: #conversionMethodsAtFileOut]. choice = 2 ifTrue: ["Don't consider this class again in the changeSet" list do: [:cls | structures removeKey: cls name ifAbsent: []]. renamed do: [:cls | nn _ (changeRecords at: cls name) priorName. structures removeKey: nn ifAbsent: []]]. choice ~= 1 ifTrue: [^ self]. "exit if choice 2,3,4" listAdd _ self askAddedInstVars: list. "Go through each inst var that was added" listDrop _ self askRemovedInstVars: list. "Go through each inst var that was removed" list _ (listAdd, listDrop) asSet asArray. smart _ SmartRefStream on: (RWBinaryOrTextStream on: '12345'). smart structures: structures. smart superclasses: superclasses. (restore _ self class current) == self ifFalse: [ self class newChanges: self]. "if not current one" msgSet _ smart conversionMethodsFor: list. "each new method is added to self (a changeSet). Then filed out with the rest." self askRenames: renamed addTo: msgSet using: smart. "renamed classes, add 2 methods" restore == self ifFalse: [self class newChanges: restore]. msgSet messageList isEmpty ifTrue: [^ self]. self inform: 'Remember to fileOut again after modifying these methods.'. MessageSet open: msgSet name: 'Conversion methods for ', self name.! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized," | aList | (aList _ self methodsWithoutClassifications) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" are categorized.'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" which have not been categorized']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 7/19/2002 20:21'! checkForUncommentedClasses "Check to see if any classes involved in this change set do not have class comments. Open up a browser showing all such classes." | aList | aList _ self changedClasses select: [:aClass | aClass theNonMetaClass organization classComment isEmptyOrNil] thenCollect: [:aClass | aClass theNonMetaClass name]. aList size > 0 ifFalse: [^ self inform: 'All classes involved in this change set have class comments'] ifTrue: [ClassListBrowser new initForClassesNamed: aList asSet asSortedArray title: 'Classes in Change Set ', self name, ': classes that lack class comments']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'! checkForUncommentedMethods | aList | "Check to see if there are any methods in the receiver that have no comments, and open a browser on all found" (aList _ self methodsWithoutComments) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have comments'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" that lack comments']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/29/2003 20:19'! checkForUnsentMessages "Check the change set for unsent messages, and if any are found, open up a message-list browser on them" | nameLine allChangedSelectors augList unsent | nameLine _ '"' , self name , '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [:each | each isValid ifTrue: [allChangedSelectors add: each methodSymbol]]. unsent _ self systemNavigation allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [^ self inform: 'There are no unsent messages in change set ' , nameLine]. self systemNavigation browseMessageList: (augList select: [:each | unsent includes: each methodSymbol]) name: 'Unsent messages in ' , nameLine! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'FBS 1/6/2004 16:59'! chooseSubjectPrefixForEmail | subjectIndex | subjectIndex _ (PopUpMenu labels: 'Bug fix [FIX]\Enhancement [ENH]\Goodie [GOODIE]\Test suite [TEST]\None of the above (will not be archived)' withCRs) startUpWithCaption: 'What type of change set\are you submitting to the list?' withCRs. ^ #('[CS] ' '[FIX] ' '[ENH] ' '[GOODIE] ' '[TEST] ' '[CS] ') at: subjectIndex + 1! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 10/15/2003 09:55'! defaultChangeSetDirectory ^self class defaultChangeSetDirectory! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 8/21/2004 14:51'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" | slips nameToUse internalStream | self checkForConversionMethods. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. nameToUse := Preferences changeSetVersionNumbers ifTrue: [self defaultChangeSetDirectory nextNameFor: self name extension: FileStream cs] ifFalse: [self name , FileDirectory dot , Utilities dateTimeSuffix, FileDirectory dot , FileStream cs]. (Preferences warningForMacOSFileNameLength and: [nameToUse size > 30]) ifTrue: [nameToUse := FillInTheBlank request: (nameToUse , '\has ' , nameToUse size asString , ' letters - too long for Mac OS.\Suggested replacement is:') withCRs initialAnswer: (nameToUse contractTo: 30). nameToUse = '' ifTrue: [^ self]]. nameToUse := self defaultChangeSetDirectory fullNameFor: nameToUse. Cursor write showWhile: [ internalStream _ WriteStream on: (String new: 10000). internalStream header; timeStamp. self fileOutPreambleOn: internalStream. self fileOutOn: internalStream. self fileOutPostscriptOn: internalStream. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: (nameToUse copyFrom: 1 to: nameToUse size - 3) isSt: false useHtml: false. ]. Preferences checkForSlips ifFalse: [^ self]. slips := self checkForSlips. (slips size > 0 and: [(PopUpMenu withCaption: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?' chooseFrom: 'Ignore\Browse slips') = 2]) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 5/23/2001 13:29'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList | (self isEmpty and: [stream isKindOf: FileStream]) ifTrue: [self inform: 'Warning: no changes to file out']. classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. "First put out rename, max classDef and comment changes." classList do: [:aClass | self fileOutClassDefinition: aClass on: stream]. "Then put out all the method changes" classList do: [:aClass | self fileOutChangesFor: aClass on: stream]. "Finally put out removals, final class defs and reorganization if any" classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. self classRemoves asSortedCollection do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'! lookForSlips "Scan the receiver for changes that the user may regard as slips to be remedied" | slips nameLine msg | nameLine _ ' "', self name, '" '. (slips _ self checkForSlips) size == 0 ifTrue: [^ self inform: 'No slips detected in change set', nameLine]. msg _ slips size == 1 ifTrue: [ 'One method in change set', nameLine, 'has a halt, reference to the Transcript, and/or some other ''slip'' in it. Would you like to browse it? ?'] ifFalse: [ slips size printString, ' methods in change set', nameLine, 'have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']. (PopUpMenu withCaption: msg chooseFrom: 'Ignore\Browse slips') = 2 ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ', name]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 4/16/2003 09:16'! mailOut "Email a compressed version of this changeset to the squeak-dev list, so that it can be shared with everyone. (You will be able to edit the email before it is sent.)" | userName message slips | userName _ MailSender userName. self checkForConversionMethods. Cursor write showWhile: [message _ self buildMessageForMailOutWithUser: userName]. MailSender sendMessage: message. Preferences suppressCheckForSlips ifTrue: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [self systemNavigation browseMessageList: slips name: 'Possible slips in ' , name] ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'md 11/14/2003 16:22'! objectForDataStream: refStrm "I am about to be written on an object file. Write a path to me in the other system instead." refStrm projectChangeSet == self ifTrue: [^ self]. "try to write reference for me" ^ DiskProxy global: #ChangeSorter selector: #existingOrNewChangeSetNamed: args: (Array with: self name) "=== refStrm replace: self with: nil. ^ nil ===" ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'nk 7/2/2003 10:47'! preambleTemplate "Answer a string that will form the default contents for a change set's preamble. Just a first stab at what the content should be." ^ String streamContents: [:strm | strm nextPutAll: '"Change Set:'. "NOTE: fileIn recognizes preambles by this string." strm tab;tab; nextPutAll: self name. strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString. strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Preferences defaultAuthorName. strm cr; cr; nextPutAll: '"'] "ChangeSet current preambleTemplate"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/30/2001 13:47'! setPreambleToSay: aString "Make aString become the preamble of this change set" preamble _ StringHolder new contents: aString! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sd 1/16/2004 21:31'! verboseFileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'changeSetVersionNumbers'" ChangeSet current fileOut. Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString! ! !ChangeSet methodsFor: 'private' stamp: 'yo 8/30/2002 13:59'! changeRecorderFor: class | cname | (class isString) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. "Later this will init the changeRecords so according to whether they should be revertable." ^ changeRecords at: cname ifAbsent: [^ changeRecords at: cname put: (ClassChangeRecord new initFor: cname revertable: revertable)]! ! !ChangeSet methodsFor: 'private' stamp: 'tk 3/7/2001 14:06'! fileOutClassDefinition: class on: stream "Write out class definition for the given class on the given stream, if the class definition was added or changed." (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. (self atClass: class includes: #change) ifTrue: [ "fat definition only needed for changes" stream command: 'H3'; nextChunkPut: (self fatDefForClass: class); cr; command: '/H3'. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ] ifFalse: [ (self atClass: class includes: #add) ifTrue: [ "use current definition for add" stream command: 'H3'; nextChunkPut: class definition; cr; command: '/H3'. DeepCopier new checkClass: class. "If veryDeepCopy weakly copies some inst vars in this class, warn author when new ones are added." ]. ]. (self atClass: class includes: #comment) ifTrue: [class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass. stream cr]. ! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 19:59'! browseChangedMessages "Create and schedule a message browser on each method that has been changed." current isEmpty ifTrue: [^ self inform: 'There are no changed messages in the current change set.']. ChangedMessageSet openFor: current! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 21:53'! current "return the current changeset" ^ current! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:24'! currentChangeSetString "ChangeSet current currentChangeSetString" ^ 'Current Change Set: ', self current name! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'NS 1/16/2004 14:49'! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current-change-set from within a project, it's vital" SystemChangeNotifier uniqueInstance noMoreNotificationsFor: current. current isolationSet: nil. current _ aChangeSet. SystemChangeNotifier uniqueInstance notify: aChangeSet ofAllSystemChangesUsing: #event:. Smalltalk currentProjectDo: [:proj | proj setChangeSet: aChangeSet. aChangeSet isolationSet: proj isolationSet]! ! !ChangeSet class methodsFor: 'current changeset' stamp: 'sd 5/22/2003 22:18'! noChanges "Initialize the system ChangeSet." current initialize! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 7/18/2004 16:13'! defaultChangeSetDirectory "Answer the directory in which to store ChangeSets. Answer the default directory if the preferred directory doesn't exist." | dir directoryName | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. dir := directoryName isEmptyOrNil ifTrue: [ FileDirectory default ] ifFalse: [ FileDirectory default directoryNamed: directoryName ]. dir exists ifTrue: [^ dir]. ^ FileDirectory default! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 3/24/2004 15:52'! defaultChangeSetDirectory: dirOrName "Set the Preference for storing change sets to the given directory or name (possibly relative). Rewrite directory names below the default directory as relative names. If dirOrName is an empty string, use the default directory." "ChangeSet defaultChangeSetDirectory: 'changeSets'" | dirName defaultFullName | dirName := dirOrName isString ifTrue: [FileDirectory default fullNameFor: dirOrName] ifFalse: [dirOrName fullName]. defaultFullName := FileDirectory default fullName. dirName = defaultFullName ifTrue: [dirName := ''] ifFalse: [(dirName beginsWith: defaultFullName , FileDirectory slash) ifTrue: [dirName := dirName copyFrom: defaultFullName size + 2 to: dirName size]]. Preferences setParameter: #defaultChangeSetDirectoryName to: dirName! ! !ChangeSet class methodsFor: 'defaults' stamp: 'dgd 9/6/2003 19:56'! defaultName ^ self uniqueNameLike: 'Unnamed' translated! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 1/4/2004 16:47'! promptForDefaultChangeSetDirectoryIfNecessary "Check the Preference (if any), and prompt the user to change it if necessary. The default if the Preference is unset is the current directory. Answer the directory." "ChangeSet promptForDefaultChangeSetDirectoryIfNecessary" | choice directoryName dir | directoryName := Preferences parameterAt: #defaultChangeSetDirectoryName ifAbsentPut: ['']. [dir := FileDirectory default directoryNamed: directoryName. dir exists] whileFalse: [choice := PopUpMenu withCaption: ('The preferred change set directory (''{1}'') does not exist. Create it or use the default directory ({2})?' translated format: { directoryName. FileDirectory default pathName }) chooseFrom: (#('Create directory' 'Use default directory and forget preference' 'Choose another directory' ) collect: [ :ea | ea translated ]). choice = 1 ifTrue: [dir assureExistence ]. choice = 3 ifTrue: [dir := FileList2 modalFolderSelector. directoryName := dir ifNil: [ '' ] ifNotNil: [dir pathName ]]]. self defaultChangeSetDirectory: directoryName. ^dir! ! !ChangeSet class methodsFor: 'defaults' stamp: 'nk 8/30/2004 08:44'! uniqueNameLike: aString | try | (ChangeSorter changeSetNamed: aString) ifNil: [^ aString]. 1 to: 999999 do: [:i | try _ aString , i printString. (ChangeSorter changeSetNamed: try) ifNil: [^ try]]! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'! basicNewNamed: aName ^ (self basicNew name: aName) initialize! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 10:02'! new "All current changeSets must be registered in the AllChangeSets collection. Due to a quirk of history, this is maintained as class variable of ChangeSorter." ^ ChangeSorter basicNewChangeSet: ChangeSet defaultName! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 7/27/2001 20:38'! addModelItemsToWindowMenu: aMenu "Add model-related items to the given window menu" | oldTarget | oldTarget _ aMenu defaultTarget. aMenu defaultTarget: self. aMenu addLine. aMenu add: 'rename change set' action: #rename. aMenu add: 'make changes go to me' action: #newCurrent. aMenu addLine. aMenu add: 'file out' action: #fileOut. aMenu add: 'browse methods' action: #browseChangeSet. aMenu addLine. myChangeSet hasPreamble ifTrue: [aMenu add: 'edit preamble' action: #addPreamble. aMenu add: 'remove preamble' action: #removePreamble] ifFalse: [aMenu add: 'add preamble' action: #addPreamble]. myChangeSet hasPostscript ifTrue: [aMenu add: 'edit postscript...' action: #editPostscript. aMenu add: 'remove postscript' action: #removePostscript] ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. aMenu add: 'destroy change set' action: #remove. aMenu addLine. Smalltalk isMorphic ifTrue: [aMenu addLine. aMenu add: 'what to show...' target: self action: #offerWhatToShowMenu]. aMenu addLine. aMenu add: 'more...' action: #offerShiftedChangeSetMenu. aMenu defaultTarget: oldTarget. ^ aMenu! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/29/2001 23:38'! openAsMorphIn: window rect: rect "Add a set of changeSetBrowser views to the given top view offset by the given amount" | aHeight | contents _ ''. aHeight _ 0.25. self addDependent: window. "so it will get changed: #relabel" window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:) frame: (((0.0@0 extent: 0.5 @ aHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0.5@0 extent: 0.5 @ aHeight) scaleBy: rect extent) translateBy: rect origin). self addLowerPanesTo: window at: (((0@aHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) with: nil! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/14/2001 10:03'! wantsAnnotationPane "This kind of browser always wants annotation panes, so answer true" ^ true! ! !ChangeSetBrowser methodsFor: 'initialization' stamp: 'sw 3/9/2001 15:02'! wantsOptionalButtons "Sure, why not?" ^ true! ! !ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 3/12/2001 14:07'! offerUnshiftedChangeSetMenu "The user chose 'more' from the shifted window menu; go back to the regular window menu" self containingWindow ifNotNil: [self containingWindow offerWindowMenu] ! ! !ChangeSetBrowser methodsFor: 'menu' stamp: 'sw 7/20/2002 18:33'! shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" Smalltalk isMorphic ifTrue: [aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial]. aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. aMenu addLine. aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: 'Check this change set for methods that do not have comments'. aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods any of whose previous authoring stamps do not start with "', Utilities authorInitials, '"']. aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. aMenu addLine. aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSetBrowser commentStamp: '' prior: 0! A tool allowing you to browse the methods of a single change set.! !ChangeSetCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 12:35'! membershipSelector: aSelector "Set the membershipSelector" membershipSelector _ aSelector! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/11/2001 16:11'! acceptsManualAdditions "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." ^ false! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:39'! changeSetList "Answer the list of change-set names in the category" | aChangeSet | self reconstituteList. keysInOrder size == 0 ifTrue: ["don't tolerate emptiness, because ChangeSorters gag when they have no change-set selected" aChangeSet _ ChangeSorter assuredChangeSetNamed: 'New Changes'. self elementAt: aChangeSet name put: aChangeSet]. ^ keysInOrder reversed! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 4/5/2001 17:26'! hasChangeForClassName: aClassName selector: aSelector otherThanIn: excludedChangeSet "Answer whether any change set in this category, other than the excluded one, has a change marked for the given class and selector" self elementsInOrder do: [:aChangeSet | (aChangeSet ~~ excludedChangeSet and: [((aChangeSet methodChangesAtClass: aClassName) includesKey: aSelector)]) ifTrue: [^ true]]. ^ false! ! !ChangeSetCategory methodsFor: 'queries' stamp: 'sw 3/30/2001 14:04'! includesChangeSet: aChangeSet "Answer whether the receiver includes aChangeSet in its retrieval list" ^ ChangeSorter perform: membershipSelector with: aChangeSet! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sd 1/16/2004 21:37'! fileOutAllChangeSets "File out all the nonempty change sets in the current category, suppressing the checks for slips that might otherwise ensue. Obtain user confirmation before undertaking this possibly prodigious task." | aList | aList _ self elementsInOrder select: [:aChangeSet | aChangeSet isEmpty not]. aList size == 0 ifTrue: [^ self inform: 'sorry, all the change sets in this category are empty']. (self confirm: 'This will result in filing out ', aList size printString, ' change set(s) Are you certain you want to do this?') ifFalse: [^ self]. Preferences setFlag: #checkForSlips toValue: false during: [ChangeSorter fileOutChangeSetsNamed: (aList collect: [:m | m name]) asSortedArray]! ! !ChangeSetCategory methodsFor: 'services' stamp: 'sw 3/30/2001 13:55'! fillAggregateChangeSet "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" | aggChangeSet | aggChangeSet _ ChangeSorter assuredChangeSetNamed: #Aggregate. aggChangeSet clear. aggChangeSet setPreambleToSay: '"Change Set: Aggregate Created at ', Time now printString, ' on ', Date today printString, ' by combining all the changes in all the change sets in the category ', categoryName printString, '"'. (self elementsInOrder copyWithout: aggChangeSet) do: [:aChangeSet | aggChangeSet assimilateAllChangesFoundIn: aChangeSet]. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup] ! ! !ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'sd 5/23/2003 14:25'! defaultChangeSetToShow "Answer the name of a change-set to show" ^ ChangeSet current! ! !ChangeSetCategory methodsFor: 'miscellaneous' stamp: 'di 4/6/2001 10:37'! reconstituteList "Clear out the receiver's elements and rebuild them" | newMembers | "First determine newMembers and check if they have not changed..." newMembers _ ChangeSorter allChangeSets select: [:aChangeSet | ChangeSorter perform: membershipSelector with: aChangeSet]. (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. "Things have changed. Need to recompute the whole category" self clear. newMembers do: [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet] ! ! !ChangeSetCategory commentStamp: '' prior: 0! A ChangeSetCategory represents a list of change sets to be shown in a ChangeSorter. It computes whether a given change set is in the list by sending its membershipSelector to ChangeSorter (i.e. the class object) with the change set as message argument.! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:34'! acceptsManualAdditions "Answer whether the user is allowed manually to manipulate the contents of the change-set-category." ^ true! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:43'! addChangeSet: aChangeSet self inform: 'sorry, you can''t do that'! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:08'! includesChangeSet: aChangeSet "Answer whether the receiver includes aChangeSet in its retrieval list" ^ ChangeSorter perform: membershipSelector withArguments: { aChangeSet } , parameters! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:04'! parameters: anArray parameters _ anArray! ! !ChangeSetCategoryWithParameters methodsFor: 'as yet unclassified' stamp: 'nk 6/26/2002 12:16'! reconstituteList "Clear out the receiver's elements and rebuild them" | newMembers | "First determine newMembers and check if they have not changed..." newMembers _ ChangeSorter allChangeSets select: [:aChangeSet | ChangeSorter perform: membershipSelector withArguments: { aChangeSet }, parameters]. (newMembers collect: [:cs | cs name]) = keysInOrder ifTrue: [^ self "all current"]. "Things have changed. Need to recompute the whole category" self clear. newMembers do: [:aChangeSet | self fasterElementAt: aChangeSet name asSymbol put: aChangeSet]! ! !ChangeSorter methodsFor: 'creation' stamp: 'sd 5/23/2003 14:25'! morphicWindow "ChangeSorter new openAsMorph" | window | myChangeSet ifNil: [self myChangeSet: ChangeSet current]. window _ (SystemWindow labelled: self labelString) model: self. self openAsMorphIn: window rect: (0@0 extent: 1@1). ^ window ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sd 5/23/2003 14:26'! open "ChangeSorterPluggable new open" | topView | Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph]. topView _ StandardSystemView new. topView model: self. myChangeSet ifNil: [self myChangeSet: ChangeSet current]. topView label: self labelString. topView borderWidth: 1; minimumSize: 360@360. self openView: topView offsetBy: 0@0. topView controller open. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sps 4/3/2004 20:15'! openAsMorphIn: window rect: rect "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 0.5@0." | csListHeight msgListHeight csMsgListHeight | contents _ ''. csListHeight _ 0.25. msgListHeight _ 0.25. csMsgListHeight _ csListHeight + msgListHeight. self addDependent: window. "so it will get changed: #relabel" "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars needs the crrentSelector pane to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added." Preferences scrollBarsOnRight ifFalse: [window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0@csListHeight extent: 1@msgListHeight) scaleBy: rect extent) translateBy: rect origin)]. window addMorph: ((PluggableListMorphByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:) autoDeselect: false) frame: (((0@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:) frame: (((0.5@0 extent: 0.5@csListHeight) scaleBy: rect extent) translateBy: rect origin). Preferences scrollBarsOnRight ifTrue: [window addMorph: (PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:) frame: (((0@csListHeight extent: 1@msgListHeight) scaleBy: rect extent) translateBy: rect origin)]. self addLowerPanesTo: window at: (((0@csMsgListHeight corner: 1@1) scaleBy: rect extent) translateBy: rect origin) with: nil. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 2/26/2001 12:00'! openView: topView offsetBy: offset "Add a set of change sorter views to the given top view offset by the given amount. To create a single change sorter, call this once with an offset of 0@0. To create a dual change sorter, call it twice with offsets of 0@0 and 360@0." | classView messageView codeView cngSetListView basePane annoPane annoHeight | contents _ ''. annoHeight _ 20. self addDependent: topView. "so it will get changed: #relabel" cngSetListView _ PluggableListViewByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:. cngSetListView window: ((0@0 extent: 180@100) translateBy: offset). topView addSubView: cngSetListView. classView _ PluggableListViewByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classListMenu:shifted: keystroke: #classListKey:from:. classView window: ((0@0 extent: 180@100) translateBy: offset). topView addSubView: classView toRightOf: cngSetListView. messageView _ PluggableListViewByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:. messageView menuTitleSelector: #messageListSelectorTitle. messageView window: ((0@0 extent: 360@100) translateBy: offset). topView addSubView: messageView below: cngSetListView. self wantsAnnotationPane ifFalse: [basePane _ messageView] ifTrue: [annoPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annoPane window: ((0@0 extent: 360@annoHeight) translateBy: offset). topView addSubView: annoPane below: messageView. basePane _ annoPane]. codeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codeView window: ((0 @ 0 extent: 360 @ 180) translateBy: offset). topView addSubView: codeView below: basePane.! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 3/29/2001 14:46'! setDefaultChangeSetCategory "Set a default ChangeSetCategory for the receiver, and answer it" ^ changeSetCategory _ self class changeSetCategoryNamed: #All! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 3/29/2001 13:01'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared." super veryDeepInner: deepCopier. "parent _ parent. Weakly copied" "myChangeSet _ myChangeSet. Weakly copied" currentClassName _ currentClassName veryDeepCopyWith: deepCopier. "currentSelector _ currentSelector. Symbol" priorChangeSetList _ priorChangeSetList veryDeepCopyWith: deepCopier. changeSetCategory _ changeSetCategory. ! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 14:45'! changeSetCategory "Answer the current changeSetCategory object that governs which change sets are shown in this ChangeSorter" ^ changeSetCategory ifNil: [self setDefaultChangeSetCategory]! ! !ChangeSorter methodsFor: 'access' stamp: 'sd 5/23/2003 14:25'! labelString "The label for my entire window. The large button that displays my name is gotten via mainButtonName" ^ String streamContents: [:aStream | aStream nextPutAll: (ChangeSet current == myChangeSet ifTrue: ['Changes go to "', myChangeSet name, '"'] ifFalse: ['ChangeSet: ', myChangeSet name]). (self changeSetCategory categoryName ~~ #All) ifTrue: [aStream nextPutAll: ' - ', self parenthesizedCategoryName]]! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 3/29/2001 22:51'! parenthesizedCategoryName "Answer my category name in parentheses" ^ ' (', self changeSetCategory categoryName, ')'! ! !ChangeSorter methodsFor: 'access' stamp: 'di 4/5/2001 21:20'! showChangeSetNamed: aName self showChangeSet: (ChangeSorter changeSetNamed: aName) ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:30'! addToCategoryOpposite "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" | categoryOpposite | categoryOpposite _ (parent other: self) changeSetCategory. categoryOpposite acceptsManualAdditions ifTrue: [categoryOpposite addChangeSet: myChangeSet. categoryOpposite reconstituteList. self update] ifFalse: [self inform: 'sorry, this command only makes sense if the category showing on the opposite side is a static category whose members are manually maintained']! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:06'! browseMethodConflicts "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." | aList | aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | (ChangeSorter allChangeSetsWithClass: aClass selector: aSelector) size > 1 ] ifNone: [^ self inform: 'No other change set has changes for any method in this change set.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 8/12/2002 17:29'! categorySubmenu: aMenu shifted: shiftedIgnored "Fill aMenu with less-frequently-needed category items" aMenu title: 'Change set category'. aMenu addStayUpItem. aMenu addList: #( ('make a new category...' makeNewCategory 'Creates a new change-set-category (you will be asked to supply a name) which will start out its life with this change set in it') ('make a new category with class...' makeNewCategoryShowingClassChanges 'Creates a new change-set-category that includes change sets that change a particular class (you will be asked to supply a name)') ('rename this category' renameCategory 'Rename this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') ('remove this category' removeCategory 'Remove this change-set category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') ('show categories of this changeset' showCategoriesOfChangeSet 'Show a list of all the change-set categories that contain this change-set; if the you choose one of the categories from this pop-up, that category will be installed in this change sorter') -). parent ifNotNil: [aMenu addList: #( ('add change set to category opposite' addToCategoryOpposite 'Adds this change set to the category on the other side of the change sorter. Only applies if the category shown on the opposite side is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.'))]. aMenu addList: #( ('remove change set from this category' removeFromCategory 'Removes this change set from the current category. Only applies when the current category being shown is a manually-maintained, user-defined category, such as you can create for yourself by choosing "make a new category..." from this same menu.') - ('file out category''s change sets' fileOutAllChangeSets 'File out every change set in this category that has anything in it. The usual checks for slips are suppressed when this command is done.') ('set recent-updates marker' setRecentUpdatesMarker 'Allows you to specify a number that will demarcate which updates are considered "recent" and which are not. This will govern which updates are included in the RecentUpdates category in a change sorter') ('fill aggregate change set' fillAggregateChangeSet 'Creates a change-set named Aggregate into which all the changes in all the change sets in this category will be copied.') - ('back to main menu' offerUnshiftedChangeSetMenu 'Takes you back to the shifted change-set menu.') ('back to shifted menu' offerShiftedChangeSetMenu 'Takes you back to the primary change-set menu.')). ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:00'! changeSetList "Answer a list of ChangeSet names to be shown in the change sorter." ^ self changeSetCategory changeSetList! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'! changeSetListKey: aChar from: view "Respond to a Command key. I am a model with a listView that has a list of changeSets." aChar == $b ifTrue: [^ self browseChangeSet]. aChar == $B ifTrue: [^ self openChangeSetBrowser]. aChar == $c ifTrue: [^ self copyAllToOther]. aChar == $D ifTrue: [^ self toggleDiffing]. aChar == $f ifTrue: [^ self findCngSet]. aChar == $m ifTrue: [^ self newCurrent]. aChar == $n ifTrue: [^ self newSet]. aChar == $o ifTrue: [^ self fileOut]. aChar == $p ifTrue: [^ self addPreamble]. aChar == $r ifTrue: [^ self rename]. aChar == $s ifTrue: [^ self chooseChangeSetCategory]. aChar == $x ifTrue: [^ self remove]. aChar == $- ifTrue: [^ self subtractOtherSide]. ^ self messageListKey: aChar from: view! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/17/2002 11:37'! changeSetMenu: aMenu shifted: isShifted "Set up aMenu to hold commands for the change-set-list pane. This could be for a single or double changeSorter" isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu]. Smalltalk isMorphic ifTrue: [aMenu title: 'Change Set'. aMenu addStayUpItemSpecial] ifFalse: [aMenu title: 'Change Set: ' , myChangeSet name]. aMenu add: 'make changes go to me (m)' action: #newCurrent. aMenu addLine. aMenu add: 'new change set... (n)' action: #newSet. aMenu add: 'find...(f)' action: #findCngSet. aMenu add: 'show category... (s)' action: #chooseChangeSetCategory. aMenu balloonTextForLastItem: 'Lets you choose which change sets should be listed in this change sorter'. aMenu add: 'select change set...' action: #chooseCngSet. aMenu addLine. aMenu add: 'rename change set (r)' action: #rename. aMenu add: 'file out (o)' action: #fileOut. aMenu add: 'mail to list' action: #mailOut. aMenu add: 'browse methods (b)' action: #browseChangeSet. aMenu add: 'browse change set (B)' action: #openChangeSetBrowser. aMenu addLine. parent ifNotNil: [aMenu add: 'copy all to other side (c)' action: #copyAllToOther. aMenu add: 'submerge into other side' action: #submergeIntoOtherSide. aMenu add: 'subtract other side (-)' action: #subtractOtherSide. aMenu addLine]. myChangeSet hasPreamble ifTrue: [aMenu add: 'edit preamble (p)' action: #addPreamble. aMenu add: 'remove preamble' action: #removePreamble] ifFalse: [aMenu add: 'add preamble (p)' action: #addPreamble]. myChangeSet hasPostscript ifTrue: [aMenu add: 'edit postscript...' action: #editPostscript. aMenu add: 'remove postscript' action: #removePostscript] ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. aMenu add: 'category functions...' action: #offerCategorySubmenu. aMenu balloonTextForLastItem: 'Various commands relating to change-set-categories'. aMenu addLine. aMenu add: 'destroy change set (x)' action: #remove. aMenu addLine. aMenu add: 'more...' action: #offerShiftedChangeSetMenu. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 3/30/2002 08:56'! checkForAnyAlienAuthorship "Open a message list browser on all uncommented methods in the current change set that have alien authorship, even historically" myChangeSet checkForAnyAlienAuthorship ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/29/2001 12:47'! checkForUnclassifiedMethods "Open a message list browser on all methods in the current change set that have not been categorized" myChangeSet checkForUnclassifiedMethods ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/18/2002 17:58'! checkForUncommentedClasses "Open a class list browser on classes in the change set that lack class comments" myChangeSet checkForUncommentedClasses! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 17:56'! chooseChangeSetCategory "Present the user with a list of change-set-categories and let her choose one" | cats aMenu result | self okToChange ifFalse: [^ self]. Smalltalk isMorphic ifTrue: [^ self chooseChangeSetCategoryInMorphic]. "gives balloon help" cats _ ChangeSetCategories elementsInOrder. aMenu _ SelectionMenu labels: (cats collect: [:cat | cat categoryName]) selections: cats. result _ aMenu startUp. result ifNotNil: [changeSetCategory _ result. self changed: #changeSetList. (self changeSetList includes: myChangeSet name) ifFalse: [self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)]. self changed: #relabel]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:24'! chooseChangeSetCategoryInMorphic "Present the user with a list of change-set-categories and let her choose one. In this morphic variant, we include balloon help" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Choose the category of change sets to show in this Change Sorter (red = current choice)'. ChangeSetCategories elementsInOrder do: [:aCategory | aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory. aCategory == changeSetCategory ifTrue: [aMenu lastItem color: Color red]. aMenu balloonTextForLastItem: aCategory documentation]. aMenu popUpInWorld! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 17:56'! chooseCngSet "Present the user with an alphabetical list of change set names, and let her choose one" | changeSetsSortedAlphabetically chosen | self okToChange ifFalse: [^ self]. changeSetsSortedAlphabetically _ self changeSetList asSortedCollection: [:a :b | a asLowercase withoutLeadingDigits < b asLowercase withoutLeadingDigits]. chosen _ (SelectionMenu selections: changeSetsSortedAlphabetically) startUp. chosen ifNil: [^ self]. self showChangeSet: (ChangeSorter changeSetNamed: chosen)! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 1/4/2004 17:07'! fileIntoNewChangeSet "Obtain a file designation from the user, and file its contents into a new change set whose name is a function of the filename. Show the new set and leave the current changeSet unaltered." | aNewChangeSet stream | self okToChange ifFalse: [^ self]. ChangeSet promptForDefaultChangeSetDirectoryIfNecessary. stream := StandardFileMenu oldFileStreamFrom: ChangeSet defaultChangeSetDirectory. stream ifNil: [^ self]. aNewChangeSet := self class newChangesFromStream: stream named: (FileDirectory localNameFor: stream name). aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 00:57'! fileOutAllChangeSets "File out all nonempty change sets in the current category, probably" self changeSetCategory fileOutAllChangeSets! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 01:26'! fillAggregateChangeSet "Create a change-set named Aggregate and pour into it all the changes in all the change-sets of the currently-selected category" self changeSetCategory fillAggregateChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nb 6/17/2003 12:25'! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates nameList | self okToChange ifFalse: [^ self]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. nameList _ self changeSetList asSet. candidates _ AllChangeSets select: [:c | (nameList includes: c name) and: [c name includesSubstring: pattern caseSensitive: false]]. candidates size = 0 ifTrue: [^ Beeper beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (PopUpMenu labels: (candidates collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:43'! makeNewCategory "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" | catName aCategory | catName _ FillInTheBlank request: 'Please give the new category a name' initialAnswer: ''. catName isEmptyOrNil ifTrue: [^ self]. catName _ catName asSymbol. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. aCategory _ StaticChangeSetCategory new categoryName: catName. ChangeSetCategories elementAt: catName put: aCategory. aCategory addChangeSet: myChangeSet. self showChangeSetCategory: aCategory! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nk 6/26/2002 12:28'! makeNewCategoryShowingClassChanges "Create a new, static change-set category, which will be populated entirely by change sets that have been manually placed in it" | catName aCategory clsName | clsName _ self selectedClass ifNotNil: [self selectedClass name ] ifNil: ['']. clsName _ FillInTheBlank request: 'Which class?' initialAnswer: clsName. clsName isEmptyOrNil ifTrue: [^ self]. catName _ ('Changes to ', clsName) asSymbol. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. aCategory _ ChangeSetCategoryWithParameters new categoryName: catName. aCategory membershipSelector: #changeSet:containsClass: ; parameters: { clsName }. ChangeSetCategories elementAt: catName put: aCategory. aCategory reconstituteList. self showChangeSetCategory: aCategory! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! methodConflictsWithOppositeCategory "Check to see if ANY change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList otherCategory | otherCategory _ (parent other: self) changeSetCategory. aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | aClass notNil and: [otherCategory hasChangeForClassName: aClass name selector: aSelector otherThanIn: myChangeSet] ] ifNone: [^ self inform: 'There are no methods that appear both in this change set and in any change set (other than this one) on the other side.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" also in some other change set in category ', otherCategory categoryName,' (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'RAA 5/28/2001 12:07'! methodConflictsWithOtherSide "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList other | self checkThatSidesDiffer: [^ self]. other _ (parent other: self) changeSet. aList _ myChangeSet messageListForChangesWhich: [ :aClass :aSelector | aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector] ] ifNone: [^ self inform: 'There are no methods that appear both in this change set and in the one on the other side.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 15:15'! newCurrent "make my change set be the current one that changes go into" ChangeSet newChanges: myChangeSet. self update. "Because list of changes in a category may thus have changed" self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:26'! newSet "Create a new changeSet and show it., making it the current one. Reject name if already in use." | aSet | self okToChange ifFalse: [^ self]. aSet _ self class newChangeSet. aSet ifNotNil: [self changeSetCategory acceptsManualAdditions ifTrue: [changeSetCategory addChangeSet: aSet]. self update. (changeSetCategory includesChangeSet: aSet) ifTrue: [self showChangeSet: aSet]. self changed: #relabel]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 17:41'! offerCategorySubmenu "Offer a menu of category-related items" self offerMenuFrom: #categorySubmenu:shifted: shifted: false! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/27/2001 21:55'! offerShiftedChangeSetMenu "Offer the shifted version of the change set menu" self offerMenuFrom: #changeSetMenu:shifted: shifted: true! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/2001 14:41'! offerUnshiftedChangeSetMenu "Offer the unshifted version of the change set menu" self offerMenuFrom: #changeSetMenu:shifted: shifted: false! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/9/2001 15:30'! openChangeSetBrowser "Open a ChangeSet browser on the current change set" Smalltalk isMorphic ifFalse: [self browseChangeSet] "msg-list browser only" ifTrue: [(ChangeSetBrowser new myChangeSet: myChangeSet) openAsMorph]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 12/13/2003 18:14'! promoteToTopChangeSet "Move the selected change-set to the top of the list" self class promoteToTop: myChangeSet. (parent ifNil: [self]) modelWakeUp! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 20:03'! removeCategory "Remove the current category" | itsName | self changeSetCategory acceptsManualAdditions ifFalse: [^ self inform: 'sorry, you can only remove manually-added categories.']. (self confirm: 'Really remove the change-set-category named ', (itsName _ changeSetCategory categoryName), '?') ifFalse: [^ self]. ChangeSetCategories removeElementAt: itsName. self setDefaultChangeSetCategory. self update! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'MU 7/1/2002 18:38'! removeContainedInClassCategories | matchExpression | myChangeSet removePreamble. matchExpression := FillInTheBlank request: 'Enter class category name (wildcard is ok)' initialAnswer: 'System-*'. (SystemOrganization categories select: [:each | matchExpression match: each]) do: [:eachCat | | classNames | classNames := SystemOrganization listAtCategoryNamed: eachCat. classNames do: [:eachClassName | myChangeSet removeClassChanges: eachClassName. myChangeSet removeClassChanges: eachClassName , ' class']. self showChangeSet: myChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 16:31'! removeFromCategory "Add the current change set to the category viewed on the opposite side, if it's of the sort to accept things like that" | aCategory | (aCategory _ self changeSetCategory) acceptsManualAdditions ifTrue: [aCategory removeElementAt: myChangeSet name. aCategory reconstituteList. self update] ifFalse: [self inform: 'sorry, this command only makes sense for static categories whose members are manually maintained']! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sd 5/23/2003 14:26'! removePrompting: doPrompt "Completely destroy my change set. Check if it's OK first, and if doPrompt is true, get the user to confirm his intentions first." | message aName changeSetNumber msg | aName _ myChangeSet name. myChangeSet okayToRemove ifFalse: [^ self]. "forms current changes for some project" (myChangeSet isEmpty or: [doPrompt not]) ifFalse: [message _ 'Are you certain that you want to remove (destroy) the change set named "', aName, '" ?'. (self confirm: message) ifFalse: [^ self]]. doPrompt ifTrue: [msg _ myChangeSet hasPreamble ifTrue: [myChangeSet hasPostscript ifTrue: ['a preamble and a postscript'] ifFalse: ['a preamble']] ifFalse: [myChangeSet hasPostscript ifTrue: ['a postscript'] ifFalse: ['']]. msg isEmpty ifFalse: [(self confirm: 'Caution!! This change set has ', msg, ' which will be lost if you destroy the change set. Do you really want to go ahead with this?') ifFalse: [^ self]]]. "Go ahead and remove the change set" changeSetNumber _ myChangeSet name initialIntegerOrNil. changeSetNumber ifNotNil: [SystemVersion current unregisterUpdate: changeSetNumber]. ChangeSorter removeChangeSet: myChangeSet. self showChangeSet: ChangeSet current.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'nb 6/17/2003 12:25'! rename "Store a new name string into the selected ChangeSet. reject duplicate name; allow user to back out" | newName | newName _ FillInTheBlank request: 'New name for this change set' initialAnswer: myChangeSet name. (newName = myChangeSet name or: [newName size == 0]) ifTrue: [^ Beeper beep]. (self class changeSetNamed: newName) ifNotNil: [^ Utilities inform: 'Sorry that name is already used']. myChangeSet name: newName. self update. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 4/11/2001 18:18'! renameCategory "Obtain a new name for the category and, if acceptable, apply it" | catName oldName | self changeSetCategory acceptsManualAdditions ifFalse: [^ self inform: 'sorry, you can only rename manually-added categories.']. catName _ FillInTheBlank request: 'Please give the new category a name' initialAnswer: (oldName _ changeSetCategory categoryName). catName isEmptyOrNil ifTrue: [^ self]. (catName _ catName asSymbol) = oldName ifTrue: [^ self inform: 'no change.']. (ChangeSetCategories includesKey: catName) ifTrue: [^ self inform: 'Sorry, there is already a category of that name']. changeSetCategory categoryName: catName. ChangeSetCategories removeElementAt: oldName. ChangeSetCategories elementAt: catName put: changeSetCategory. self update! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/2001 11:03'! reorderChangeSets "apply a standard reordering -- let the class handle this" ^ self class reorderChangeSets! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:37'! setRecentUpdatesMarker "Allow the user to change the recent-updates marker" | result | result _ FillInTheBlank request: ('Enter the lowest change-set number that you wish to consider "recent"? (note: highest change-set number in this image at this time is ', self class highestNumberedChangeSet asString, ')') initialAnswer: self class recentUpdateMarker asString. (result notNil and: [result startsWithDigit]) ifTrue: [self class recentUpdateMarker: result asInteger. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'mu 12/11/2003 20:05'! shiftedChangeSetMenu: aMenu "Set up aMenu to hold items relating to the change-set-list pane when the shift key is down" Smalltalk isMorphic ifTrue: [aMenu title: 'Change set (shifted)'. aMenu addStayUpItemSpecial]. "CONFLICTS SECTION" aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. parent ifNotNil: [aMenu add: 'conflicts with change set opposite' action: #methodConflictsWithOtherSide. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'. aMenu add: 'conflicts with category opposite' action: #methodConflictsWithOppositeCategory. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in ANY change set in the category list on the opposite side of this change sorter, other of course than this change set itself. (Caution -- this could be VERY slow)']. aMenu addLine. "CHECKS SECTION" aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu add: 'check for uncommented methods' action: #checkForUncommentedMethods. aMenu balloonTextForLastItem: 'Check this change set for methods that do not have comments'. aMenu add: 'check for uncommented classes' action: #checkForUncommentedClasses. aMenu balloonTextForLastItem: 'Check for classes with code in this changeset which lack class comments'. Utilities authorInitialsPerSe isEmptyOrNil ifFalse: [aMenu add: 'check for other authors' action: #checkForAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods whose current authoring stamp does not start with "', Utilities authorInitials, '"'. aMenu add: 'check for any other authors' action: #checkForAnyAlienAuthorship. aMenu balloonTextForLastItem: 'Check this change set for methods any of whose authoring stamps do not start with "', Utilities authorInitials, '"']. aMenu add: 'check for uncategorized methods' action: #checkForUnclassifiedMethods. aMenu balloonTextForLastItem: 'Check to see if any methods in the selected change set have not yet been assigned to a category. If any are found, open a browser on them.'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. aMenu balloonTextForLastItem: 'Make this change set appear first in change-set lists in all change sorters.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'remove contained in class categories...' action: #removeContainedInClassCategories. aMenu balloonTextForLastItem: ' Drops any changes in given class categories'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu add: 'expunge uniclasses' action: #expungeUniclasses. aMenu balloonTextForLastItem: 'Remove from the change set all memory of uniclasses, e.g. classes added on behalf of etoys, fabrik, etc., whose classnames end with a digit.'. aMenu add: 'uninstall this change set' action: #uninstallChangeSet. aMenu balloonTextForLastItem: 'Attempt to uninstall this change set. CAUTION: this may not work completely and is irreversible!!'. aMenu addLine. aMenu add: 'file into new...' action: #fileIntoNewChangeSet. aMenu balloonTextForLastItem: 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. aMenu add: 'reorder all change sets' action: #reorderChangeSets. aMenu balloonTextForLastItem: 'Applies a standard reordering of all change-sets in the system -- at the bottom will come the sets that come with the release; next will come all the numbered updates; finally, at the top, will come all other change sets'. aMenu addLine. aMenu add: 'more...' action: #offerUnshiftedChangeSetMenu. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 8/11/2002 01:11'! showCategoriesOfChangeSet "Show a list of all the categories in which the selected change-set occurs at the moment. Install the one the user chooses, if any." | aMenu | Smalltalk isMorphic ifFalse: [self inform: 'Only available in morphic, right now, sorry. It would not take much to make this also work in mvc, so if you are inclined to do that, thanks in advance...'] ifTrue: [aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Categories which contain change set "', myChangeSet name, '"'. ChangeSetCategories elementsInOrder do: [:aCategory | (aCategory includesChangeSet: myChangeSet) ifTrue: [aMenu add: aCategory categoryName target: self selector: #showChangeSetCategory: argument: aCategory. aCategory == changeSetCategory ifTrue: [aMenu lastItem color: Color red]]. aMenu balloonTextForLastItem: aCategory documentation]. aMenu popUpInWorld]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/30/2001 13:27'! showChangeSetCategory: aChangeSetCategory "Show the given change-set category" changeSetCategory _ aChangeSetCategory. self changed: #changeSetList. (self changeSetList includes: myChangeSet name) ifFalse: [self showChangeSet: (ChangeSorter changeSetNamed: self changeSetList first)]. self changed: #relabel! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 4/5/2001 21:22'! submergeIntoOtherSide "Copy the contents of the receiver to the other side, then remove the receiver -- all after checking that all is well." | other message nextToView i | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ self]. other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self inform: 'Both sides are the same!!']. myChangeSet isEmpty ifTrue: [^ self inform: 'Nothing to copy. To remove, simply choose "remove".']. myChangeSet okayToRemove ifFalse: [^ self]. message _ 'Please confirm: copy all changes in "', myChangeSet name, '" into "', other name, '" and then destroy the change set named "', myChangeSet name, '"?'. (self confirm: message) ifFalse: [^ self]. (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble or a postscript or both. If you submerge it into the other side, these will be lost. Do you really want to go ahead with this?') ifFalse: [^ self]]. other assimilateAllChangesFoundIn: myChangeSet. nextToView _ ((AllChangeSets includes: myChangeSet) and: [(i _ AllChangeSets indexOf: myChangeSet) < AllChangeSets size]) ifTrue: [AllChangeSets at: i+1] ifFalse: [other]. self removePrompting: false. self showChangeSet: nextToView. parent modelWakeUp. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/20/2001 09:37'! updateIfNecessary "Recompute all of my panes." | newList | self okToChange ifFalse: [^ self]. myChangeSet ifNil: [^ self]. "Has been known to happen though shouldn't" (myChangeSet isMoribund or: [(changeSetCategory notNil and: [changeSetCategory includesChangeSet: myChangeSet]) not]) ifTrue: [self changed: #changeSetList. ^ self showChangeSet: self changeSetCategory defaultChangeSetToShow]. newList _ self changeSetList. (priorChangeSetList == nil or: [priorChangeSetList ~= newList]) ifTrue: [priorChangeSetList _ newList. self changed: #changeSetList]. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/29/2001 15:19'! classList "Computed. View should try to preserve selections, even though index changes" ^ myChangeSet ifNotNil: [myChangeSet changedClassNames] ifNil: [OrderedCollection new] ! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:24'! classListKey: aChar from: view "Respond to a Command key in the class-list pane." aChar == $x ifTrue: [^ self removeClass]. aChar == $d ifTrue: [^ self forgetClass]. ^ self messageListKey: aChar from: view "picks up b,h,p"! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 11/3/2001 09:34'! classListMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the class list" aMenu title: 'class list'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. (parent notNil and: [shifted not]) ifTrue: [aMenu addList: #( "These two only apply to dual change sorters" ('copy class chgs to other side' copyClassToOther) ('move class chgs to other side' moveClassToOther))]. aMenu addList: (shifted ifFalse: [#( - ('delete class from change set (d)' forgetClass) ('remove class from system (x)' removeClass) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse protocol (p)' browseFullProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('more...' offerShiftedClassListMenu))] ifTrue: [#( - ('unsent methods' browseUnusedMethods) ('unreferenced inst vars' showUnreferencedInstVars) ('unreferenced class vars' showUnreferencedClassVars) - ('sample instance' makeSampleInstance) ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('more...' offerUnshiftedClassListMenu ))]). ^ aMenu! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 2/26/2001 12:00'! classMenu: aMenu "Set up aMenu for the class-list. Retained for backward compatibility with old change sorters in image segments" ^ self classListMenu: aMenu shifted: false! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/6/2001 12:40'! classMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the class list. Retained for bkwd compatibility" ^ self classListMenu: aMenu shifted: shifted! ! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! copyClassToOther "Place these changes in the other changeSet also" | otherSorter otherChangeSet | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentClassName ifNil: [^ Beeper beep]. otherSorter _ parent other: self. otherChangeSet _ otherSorter changeSet. otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. otherSorter showChangeSet: otherChangeSet.! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 3/5/2001 18:30'! messageListKey: aChar from: view "Respond to a Command key in the message-list pane." aChar == $d ifTrue: [^ self forget]. super messageListKey: aChar from: view! ! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self checkThatSidesDiffer: [^ self]. (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. self copyClassToOther. self forgetClass! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 3/9/2001 14:27'! messageListMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" ^ self messageMenu: aMenu shifted: shifted! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 3/5/2001 18:26'! messageMenu: aMenu shifted: shifted "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" shifted ifTrue: [^ self shiftedMessageMenu: aMenu]. aMenu title: 'message list'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. parent ifNotNil: [aMenu addList: #( ('copy method to other side' copyMethodToOther) ('move method to other side' moveMethodToOther))]. aMenu addList: #( ('delete method from changeSet (d)' forget) - ('remove method from system (x)' removeMessage) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' spawnHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !ChangeSorter methodsFor: 'message list' stamp: 'nk 7/30/2004 17:58'! moveMethodToOther "Place this change in the other changeSet and remove it from this side" | other cls sel | self checkThatSidesDiffer: [^self]. self okToChange ifFalse: [^Beeper beep]. currentSelector ifNotNil: [other := (parent other: self) changeSet. other == myChangeSet ifTrue: [^Beeper beep]. cls := self selectedClassOrMetaClass. sel := currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other. self forget "removes the method from this side"]! ! !ChangeSorter methodsFor: 'message list' stamp: 'sd 5/11/2003 18:38'! removeMessage "Remove the selected msg from the system. Real work done by the parent, a ChangeSorter" | confirmation sel | self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [confirmation _ self systemNavigation confirmRemovalOf: (sel _ self selectedMessageName) on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:35'! setContents "return the source code that shows in the bottom pane" | sel class strm changeType | self clearUserEditFlag. currentClassName ifNil: [^ contents _ myChangeSet preambleString ifNil: ['']]. class _ self selectedClassOrMetaClass. (sel _ currentSelector) == nil ifFalse: [changeType _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class). changeType == #remove ifTrue: [^ contents _ 'Method has been removed (see versions)']. changeType == #addedThenRemoved ifTrue: [^ contents _ 'Added then removed (see versions)']. class ifNil: [^ contents _ 'Method was added, but cannot be found!!']. (class includesSelector: sel) ifFalse: [^ contents _ 'Method was added, but cannot be found!!']. contents _ class sourceCodeAt: sel. (#(prettyPrint colorPrint prettyDiffs altSyntax) includes: contentsSymbol) ifTrue: [contents _ class compilerClass new format: contents in: class notifying: nil contentsSymbol: contentsSymbol]. self showingAnyKindOfDiffs ifTrue: [contents _ self diffFromPriorSourceFor: contents]. ^ contents _ contents asText makeSelectorBoldIn: class] ifTrue: [strm _ WriteStream on: (String new: 100). (myChangeSet classChangeAt: currentClassName) do: [:each | each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr]. each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.']. each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr]. each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr]. each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr]. each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr]. each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr. ]]. ^ contents _ strm contents].! ! !ChangeSorter methodsFor: 'code pane' stamp: 'sw 11/13/2001 07:34'! toggleDiffing "Toggle whether diffs should be shown in the code pane" self okToChange ifTrue: [super toggleDiffing. self changed: #contents. self update] ! ! !ChangeSorter methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:35'! addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "Add an annotation detailing the prior versions count. Specially handled here for the case of a selector no longer in the system, whose prior version is pointed to by the lost-method pointer in the change held on to by the changeset" (aClass includesSelector: aSelector) ifTrue: [^ super addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aStream nextPutAll: ((myChangeSet methodInfoFromRemoval: {aClass name. aSelector}) ifNil: ['no prior versions'] ifNotNil: ['version(s) retrievable here']), self annotationSeparator! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:33'! allChangeSetNames ^ self allChangeSets collect: [:c | c name]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:27'! allChangeSets "Return the list of all current ChangeSets" ^ AllChangeSets! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:34'! allChangeSetsWithClass: class selector: selector class ifNil: [^ #()]. ^ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'nk 6/26/2002 12:39'! changeSet: aChangeSet containsClass: aClass | theClass | theClass _ Smalltalk classNamed: aClass. theClass ifNil: [^ false]. ^ aChangeSet containsClass: theClass! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'! changeSetNamed: aName "Return the change set of the given name, or nil if none found. 1/22/96 sw" ^ AllChangeSets detect: [:aChangeSet | aChangeSet name = aName] ifNone: [nil]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 19:42'! changeSetsNamedSuchThat: nameBlock "(ChangeSorter changeSetsNamedSuchThat: [:name | name first isDigit and: [name initialInteger >= 373]]) do: [:cs | AllChangeSets remove: cs wither]" ^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/6/2001 09:49'! existingOrNewChangeSetNamed: aName | newSet | ^(self changeSetNamed: aName) ifNil: [ newSet _ ChangeSet basicNewNamed: aName. AllChangeSets add: newSet. newSet ]! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'di 4/5/2001 21:37'! mostRecentChangeSetWithChangeForClass: class selector: selector | hits | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ 'not in any change set']. ^ 'recent cs: ', hits last name! ! !ChangeSorter class methodsFor: 'enumerating' stamp: 'sw 12/13/2003 18:22'! promoteToTop: aChangeSet "Make aChangeSet the first in the list from now on" AllChangeSets remove: aChangeSet ifAbsent: [^ self]. AllChangeSets add: aChangeSet! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 16:01'! belongsInAdditions: aChangeSet "Answer whether a change set belongs in the Additions category, which is fed by all change sets that are neither numbered nor in the initial release" ^ (((self belongsInProjectsInRelease: aChangeSet) or: [self belongsInNumbered: aChangeSet])) not! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:38'! belongsInAll: aChangeSet "Answer whether a change set belongs in the All category" ^ true ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:47'! belongsInMyInitials: aChangeSet "Answer whether a change set belongs in the MyInitials category. " ^ aChangeSet name endsWith: ('-', Utilities authorInitials)! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:45'! belongsInNumbered: aChangeSet "Answer whether a change set belongs in the Numbered category. " ^ aChangeSet name startsWithDigit! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:49'! belongsInProjectChangeSets: aChangeSet "Answer whether a change set belongs in the MyInitials category. " ^ aChangeSet belongsToAProject! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:44'! belongsInProjectsInRelease: aChangeSet "Answer whether a change set belongs in the ProjectsInRelease category. You can hand-tweak this to suit your working style. This just covers the space of project names in the 2.9, 3.0, and 3.1a systems" | aString | ^ ((aString _ aChangeSet name) beginsWith: 'Play With Me') or: [self changeSetNamesInReleaseImage includes: aString]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 12:56'! belongsInRecentUpdates: aChangeSet "Answer whether a change set belongs in the RecentUpdates category." ^ aChangeSet name startsWithDigit and: [aChangeSet name asInteger >= self recentUpdateMarker]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/29/2001 14:44'! changeSetCategoryNamed: aName "Answer the changeSetCategory of the given name, or nil if none" ^ ChangeSetCategories elementAt: aName asSymbol ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:47'! changeSetNamesInReleaseImage "Answer a list of names of project change sets that come pre-shipped in the latest sytem release. On the brink of shipping a new release, call 'ChangeSorter noteChangeSetsInRelease' " ^ ChangeSetNamesInRelease ifNil: [ChangeSetNamesInRelease _ self changeSetNamesInThreeOh]! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:45'! changeSetNamesInThreeOh "Hard-coded: answer a list of names of project change sets that came pre-shipped in Squeak 3.0" ^ #('The Worlds of Squeak' 'Fun with Morphic' 'Games' 'Fun With Music' 'Building with Squeak' 'Squeak and the Internet' 'Squeak in 3D' 'More About Sound' ) ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:41'! initialize "Initialize the class variables" AllChangeSets == nil ifTrue: [AllChangeSets _ OrderedCollection new]. self gatherChangeSets. ChangeSetCategories ifNil: [self initializeChangeSetCategories]. RecentUpdateMarker _ 0. "ChangeSorter initialize" FileList registerFileReader: self. self registerInFlapsRegistry. ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 3/30/2001 13:30'! initializeChangeSetCategories "Initialize the set of change-set categories" "ChangeSorter initializeChangeSetCategories" | aCategory | ChangeSetCategories _ ElementCategory new categoryName: #ChangeSetCategories. aCategory _ ChangeSetCategory new categoryName: #All. aCategory membershipSelector: #belongsInAll:. aCategory documentation: 'All change sets known to the system'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #Additions. aCategory membershipSelector: #belongsInAdditions:. aCategory documentation: 'All unnumbered change sets except those representing projects in the system as initially released.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #MyInitials. aCategory membershipSelector: #belongsInMyInitials:. aCategory documentation: 'All change sets whose names end with the current author''s initials.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #Numbered. aCategory membershipSelector: #belongsInNumbered:. aCategory documentation: 'All change sets whose names start with a digit -- normally these will be the official updates to the system.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #ProjectChangeSets. aCategory membershipSelector: #belongsInProjectChangeSets:. aCategory documentation: 'All change sets that are currently associated with projects present in the system right now.'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #ProjectsInRelease. aCategory membershipSelector: #belongsInProjectsInRelease:. aCategory documentation: 'All change sets belonging to projects that were shipped in the initial release of this version of Squeak'. ChangeSetCategories addCategoryItem: aCategory. aCategory _ ChangeSetCategory new categoryName: #RecentUpdates. aCategory membershipSelector: #belongsInRecentUpdates:. aCategory documentation: 'Updates whose numbers are at or beyond the number I have designated as the earliest one to qualify as Recent'. ChangeSetCategories addCategoryItem: aCategory. ChangeSetCategories elementsInOrder do: [:anElem | anElem reconstituteList] ! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'sw 4/16/2002 00:47'! noteChangeSetsInRelease "Freshly compute what the change sets in the release are; to be called manually just before a release" ChangeSetNamesInRelease _ (Project allProjects collect: [:p | p name]) asSet asOrderedCollection. "ChangeSorter noteChangeSetsInRelease"! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:42'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set') forFlapNamed: 'Tools']! ! !ChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:32'! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !ChangeSorter class methodsFor: 'adding' stamp: 'di 4/6/2001 09:46'! basicNewChangeSet: newName | newSet | newName ifNil: [^ nil]. (self changeSetNamed: newName) ifNotNil: [self inform: 'Sorry that name is already used'. ^ nil]. newSet _ ChangeSet basicNewNamed: newName. AllChangeSets add: newSet. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'sd 5/23/2003 15:15'! newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | newName _ FillInTheBlank request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmptyOrNil ifTrue: [^ nil]. newSet _ self basicNewChangeSet: newName. newSet ifNotNil: [ChangeSet newChanges: newSet]. ^ newSet! ! !ChangeSorter class methodsFor: 'adding' stamp: 'yo 8/17/2004 10:07'! newChangesFromStream: aStream named: aName "File in the code from the stream into a new change set whose name is derived from aName. Leave the 'current change set' unchanged. Return the new change set or nil on failure." | oldChanges newName newSet newStream | oldChanges _ ChangeSet current. PreviousSet _ oldChanges name. "so a Bumper update can find it" newName _ aName sansPeriodSuffix. newSet _ self basicNewChangeSet: newName. [newSet ifNotNil: [ (aStream respondsTo: #converter:) ifFalse: [ newStream _ MultiByteBinaryOrTextStream with: (aStream contentsOfEntireFile). newStream reset. ] ifTrue: [ newStream _ aStream. ]. ChangeSet newChanges: newSet. newStream setConverterForCode. newStream fileInAnnouncing: 'Loading ', newName, '...'. Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName]. aStream close] ensure: [ ChangeSet newChanges: oldChanges]. ^ newSet! ! !ChangeSorter class methodsFor: 'removing' stamp: 'di 4/5/2001 21:12'! removeChangeSetsNamedSuchThat: nameBlock (ChangeSorter changeSetsNamedSuchThat: nameBlock) do: [:cs | self removeChangeSet: cs]! ! !ChangeSorter class methodsFor: 'removing' stamp: 'di 4/5/2001 21:13'! removeEmptyUnnamedChangeSets "Remove all change sets that are empty, whose names start with Unnamed, and which are not nailed down by belonging to a Project." "ChangeSorter removeEmptyUnnamedChangeSets" | toGo | (toGo _ (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) do: [:cs | self removeChangeSet: cs]. self inform: toGo size printString, ' change set(s) removed.'! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 13:43'! assuredChangeSetNamed: aName "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." | existing | ^ (existing _ self changeSetNamed: aName) ifNotNil: [existing] ifNil: [self basicNewChangeSet: aName]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:30'! browseChangeSetsWithClass: class selector: selector "Put up a menu comprising a list of change sets that hold changes for the given class and selector. If the user selects one, open a single change-sorter onto it" | hits index | hits _ self allChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ self inform: class name, '.', selector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSorter new myChangeSet: (hits at: index)) open. ! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 5/23/2001 13:31'! browseChangeSetsWithSelector: aSelector "Put up a list of all change sets that contain an addition, deletion, or change of any method with the given selector" | hits index | hits _ self allChangeSets select: [:cs | cs hasAnyChangeForSelector: aSelector]. hits isEmpty ifTrue: [^ self inform: aSelector , ' is not in any change set']. index _ hits size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: (hits collect: [:cs | cs name]) lines: #()) startUp]. index = 0 ifTrue: [^ self]. (ChangeSetBrowser new myChangeSet: (hits at: index)) open "ChangeSorter browseChangeSetsWithSelector: #clearPenTrails" ! ! !ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:36'! buildAggregateChangeSet "Establish a change-set named Aggregate which bears the union of all the changes in all the existing change-sets in the system (other than any pre-existing Aggregate). This can be useful when wishing to discover potential conflicts between a disk-resident change-set and an image. Formerly very useful, now some of its unique contributions have been overtaken by new features" | aggregateChangeSet | aggregateChangeSet _ self existingOrNewChangeSetNamed: 'Aggregate'. aggregateChangeSet clear. self allChangeSets do: [:aChangeSet | aChangeSet == aggregateChangeSet ifFalse: [aggregateChangeSet assimilateAllChangesFoundIn: aChangeSet]] "ChangeSorter buildAggregateChangeSet" ! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:51'! countOfChangeSetsWithClass: aClass andSelector: aSelector "Answer how many change sets record a change for the given class and selector" ^ (self allChangeSetsWithClass: aClass selector: aSelector) size! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/6/2001 12:52'! doesAnyChangeSetHaveClass: aClass andSelector: aSelector "Answer whether any known change set bears a change for the given class and selector" ^ (self countOfChangeSetsWithClass: aClass andSelector: aSelector) > 0! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 6/13/2001 00:56'! prototypicalToolWindow "Answer a window representing a prototypical instance of the receiver" ^ self new morphicWindow applyModelExtent! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 00:30'! recentUpdateMarker "Answer the number representing the threshold of what counts as 'recent' for an update number. This allow you to use the RecentUpdates category in a ChangeSorter to advantage" ^ RecentUpdateMarker ifNil: [RecentUpdateMarker _ 0]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sw 3/30/2001 00:30'! recentUpdateMarker: aNumber "Set the recent update marker as indicated" ^ RecentUpdateMarker _ aNumber! ! !ChangeSorter class methodsFor: 'services' stamp: 'di 4/5/2001 21:14'! reorderChangeSets "Change the order of the change sets to something more convenient: First come the project changesets that come with the release. These are mostly empty. Next come all numbered updates. Next come all remaining changesets In a ChangeSorter, they will appear in the reversed order." "ChangeSorter reorderChangeSets" | newHead newMid newTail | newHead _ OrderedCollection new. newMid _ OrderedCollection new. newTail _ OrderedCollection new. AllChangeSets do: [:aChangeSet | (self belongsInProjectsInRelease: aChangeSet) ifTrue: [newHead add: aChangeSet] ifFalse: [(self belongsInNumbered: aChangeSet) ifTrue: [newMid add: aChangeSet] ifFalse: [newTail add: aChangeSet]]]. AllChangeSets _ newHead, newMid, newTail. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! ! !ChangeSorter class methodsFor: 'services' stamp: 'sd 5/23/2003 14:27'! secondaryChangeSet "Answer a likely change set to use as the second initial one in a Dual Change Sorter. " AllChangeSets size = 1 ifTrue: [^ AllChangeSets first]. AllChangeSets last == ChangeSet current ifTrue: [^ AllChangeSets at: (AllChangeSets size - 1)] ifFalse: [^ AllChangeSets last]! ! !ChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:09'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A tool that lets you see the code for one change set at a time.'! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:45'! fileIntoNewChangeSet: fullName "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | fullName ifNil: [^ Beeper beep]. ff _ FileStream readOnlyFileNamed: (fn _ GZipReadStream uncompressedFileName: fullName). self newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 15:52'! fileReaderServicesForFile: fullName suffix: suffix ^ (FileStream isSourceFileSuffix: suffix) ifTrue: [ self services] ifFalse: [#()]! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 01:36'! serviceFileIntoNewChangeSet "Answer a service for installing a file into a new change set" ^ SimpleServiceEntry provider: self label: 'install into new change set' selector: #fileIntoNewChangeSet: description: 'install the file as a body of code in the image: create a new change set and file-in the selected file into it' buttonLabel: 'install'! ! !ChangeSorter class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:47'! services ^ Array with: self serviceFileIntoNewChangeSet ! ! !ChangeSorter class methodsFor: 'utilities' stamp: 'sd 1/16/2004 21:36'! fileOutChangeSetsNamed: nameList "File out the list of change sets whose names are provided" "ChangeSorter fileOutChangeSetsNamed: #('New Changes' 'miscTidies-sw')" | notFound aChangeSet infoString empty | notFound _ OrderedCollection new. empty _ OrderedCollection new. nameList do: [:aName | (aChangeSet _ self changeSetNamed: aName) ifNotNil: [aChangeSet isEmpty ifTrue: [empty add: aName] ifFalse: [aChangeSet fileOut]] ifNil: [notFound add: aName]]. infoString _ (nameList size - notFound size) printString, ' change set(s) filed out'. notFound size > 0 ifTrue: [infoString _ infoString, ' ', notFound size printString, ' change set(s) not found:'. notFound do: [:aName | infoString _ infoString, ' ', aName]]. empty size > 0 ifTrue: [infoString _ infoString, ' ', empty size printString, ' change set(s) were empty:'. empty do: [:aName | infoString _ infoString, ' ', aName]]. self inform: infoString! ! !ChangedMessageSet methodsFor: 'acceptance' stamp: 'sw 6/26/2001 11:42'! contents: aString notifying: aController "Accept the string as new source for the current method, and make certain the annotation pane gets invalidated" | existingSelector existingClass superResult newSelector | existingSelector _ self selectedMessageName. existingClass _ self selectedClassOrMetaClass. superResult _ super contents: aString notifying: aController. superResult ifTrue: "succeeded" [newSelector _ Parser new parseSelector: aString. newSelector ~= existingSelector ifTrue: "Selector changed -- maybe an addition" [self reformulateList. self changed: #messageList. self messageList doWithIndex: [:aMethodReference :anIndex | (aMethodReference actualClass == existingClass and: [aMethodReference methodSymbol == newSelector]) ifTrue: [self messageListIndex: anIndex]]]]. ^ superResult! ! !ChangedMessageSet methodsFor: 'reformulation' stamp: 'sw 6/26/2001 11:20'! reformulateList "Reformulate the message list of the receiver" self initializeMessageList: (changeSet changedMessageListAugmented select: [:each | each isValid]) ! ! !ChangedMessageSet commentStamp: '' prior: 0! A ChangedMessageSet is a message set associated with a change-set; it bears an entry for every method added or changed in the change set, as well as for every class-comment of which the change-set bears a note.! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/29/2001 10:19'! openFor: aChangeSet "Open up a ChangedMessageSet browser on the given change set; this is a conventional message-list browser whose message-list consists of all the methods in aChangeSet. After any method submission, the message list is refigured, making it plausibly dynamic" | messageSet | messageSet _ aChangeSet changedMessageListAugmented select: [ :each | each isValid]. self openMessageList: messageSet name: 'Methods in Change Set ', aChangeSet name autoSelect: nil changeSet: aChangeSet! ! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 11:42'! openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet | messageSet | messageSet _ self messageList: messageList. messageSet changeSet: aChangeSet. messageSet autoSelectString: autoSelectString. Smalltalk isMorphic ifTrue: [self openAsMorph: messageSet name: labelString] ifFalse: [ScheduledControllers scheduleActive: (self open: messageSet name: labelString)]! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'! charCode ^ (value bitAnd: 16r3FFFFF). ! ! !Character methodsFor: 'accessing' stamp: 'RAH 4/25/2000 19:49'! codePoint "Return the encoding value of the receiver." #Fundmntl. ^ self asciiValue! ! !Character methodsFor: 'accessing' stamp: 'yo 12/1/2003 19:30'! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." ^ (EncodedCharSet charsetAt: self leadingChar) digitValue: self. ! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:14'! leadingChar ^ (value bitAnd: (16r3FC00000)) bitShift: -22. ! ! !Character methodsFor: 'comparing' stamp: 'yo 8/27/2002 15:16'! = aCharacter "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer) and false otherwise. Optional. See Object documentation whatIsAPrimitive." "" ^ self == aCharacter or: [aCharacter class == MultiCharacter and: [aCharacter asciiValue = self asciiValue]]. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:57'! canBeGlobalVarInitial ^ (EncodedCharSet charsetAt: self leadingChar) canBeGlobalVarInitial: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:58'! canBeNonGlobalVarInitial ^ (EncodedCharSet charsetAt: self leadingChar) canBeNonGlobalVarInitial: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'! isCharacter ^ true. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! isDigit ^ (EncodedCharSet charsetAt: self leadingChar) isDigit: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! isLetter ^ (EncodedCharSet charsetAt: self leadingChar) isLetter: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! isLowercase ^ (EncodedCharSet charsetAt: self leadingChar) isLowercase: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'! isOctetCharacter ^ value < 256. ! ! !Character methodsFor: 'testing' stamp: 'gg 6/2/2004 15:18'! isSafeForHTTP "whether a character is 'safe', or needs to be escaped when used, eg, in a URL" "[GG] See http://www.faqs.org/rfcs/rfc1738.html. ~ is unsafe and has been removed" ^ value < 128 and: [self isAlphaNumeric or: ['.-_' includes: self]]! ! !Character methodsFor: 'testing' stamp: 'yo 12/30/2002 15:55'! isUnicode ^ false. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/5/2003 16:43'! isUppercase ^ (EncodedCharSet charsetAt: self leadingChar) isUppercase: self. ! ! !Character methodsFor: 'copying' stamp: 'tk 12/9/2000 11:46'! clone "Answer with the receiver, because Characters are unique."! ! !Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:35'! asLowercase "If the receiver is uppercase, answer its matching lowercase Character." "A tentative implementation. Eventually this should consult the Unicode table." | v | v _ self charCode. (((8r101 <= v and: [v <= 8r132]) or: [16rC0 <= v and: [v <= 16rD6]]) or: [16rD8 <= v and: [v <= 16rDE]]) ifTrue: [^ Character value: value + 8r40] ifFalse: [^ self]! ! !Character methodsFor: 'converting' stamp: 'raa 5/26/2001 09:54'! asSymbol "Answer a Symbol consisting of the receiver as the only element." ^Symbol internCharacter: self! ! !Character methodsFor: 'converting' stamp: 'yo 12/30/2002 11:36'! asUnicode ^ value ! ! !Character methodsFor: 'converting' stamp: 'yo 8/16/2004 11:34'! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." "A tentative implementation. Eventually this should consult the Unicode table." | v | v _ self charCode. (((8r141 <= v and: [v <= 8r172]) or: [16rE0 <= v and: [v <= 16rF6]]) or: [16rF8 <= v and: [v <= 16rFE]]) ifTrue: [^ Character value: value - 8r40] ifFalse: [^ self] ! ! !Character methodsFor: 'converting' stamp: 'yo 8/11/2003 21:18'! basicSqueakToIso | asciiValue | value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 253 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 254 255 256 ) at: self asciiValue - 127. ^ Character value: asciiValue. ! ! !Character methodsFor: 'converting' stamp: 'yo 8/18/2003 19:25'! isoToSqueak "Convert receiver from iso8895-1 (actually CP1252) to mac encoding. Does not do lf/cr conversion!! To make the round-trip conversion possible, each undefined code point is mapped to a unique value. For each c in Character, c squeakToIso isoToSqueak = c, and c isoToSqueak squeakToIso = c is true. Also, for each array literals in squeakToIso and isoToSqueak, self size = self asSet size is true. Finally, the table is compabie with the 'keymap' table in the Windows VM. " value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. ^ Character value: (#( 173 176 226 196 227 201 160 224 246 228 178 220 206 179 182 183 "80-8F" 184 212 213 210 211 165 208 209 247 170 185 221 207 186 189 217 "90-9F" 202 193 162 163 219 180 195 164 172 169 187 199 194 197 168 248 "A0-AF" 161 177 198 215 171 181 166 225 252 218 188 200 222 223 240 192 "B0-BF" 203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 "C0-CF" 245 132 241 238 239 205 133 249 175 244 242 243 134 250 251 167 "D0-DF" 136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149 "E0-EF" 253 150 152 151 153 155 154 214 191 157 156 158 159 254 255 216 "F0-FF" ) at: value - 127) ! ! !Character methodsFor: 'converting' stamp: 'yo 8/18/2003 17:02'! squeakToIso | asciiValue | value < 128 ifTrue: [^ self]. value > 255 ifTrue: [^ self]. asciiValue _ #(196 197 199 201 209 214 220 225 224 226 228 227 229 231 233 232 234 235 237 236 238 239 241 243 242 244 246 245 250 249 251 252 134 176 162 163 167 149 182 223 174 169 153 180 168 128 198 216 129 177 138 141 165 181 142 143 144 154 157 170 186 158 230 248 191 161 172 166 131 173 178 171 187 133 160 192 195 213 140 156 150 151 147 148 145 146 247 179 255 159 185 164 139 155 188 189 135 183 130 132 137 194 202 193 203 200 205 206 207 204 211 212 190 210 218 219 217 208 136 152 175 215 221 222 184 240 253 254 ) at: self asciiValue - 127. ^ Character value: asciiValue. ! ! !Character methodsFor: 'object fileIn' stamp: 'tk 2/16/2001 14:52'! objectForDataStream: refStrm "I am being collected for inclusion in a segment. Do not include Characters!! Let them be in outPointers." refStrm insideASegment ifFalse: ["Normal use" ^ self] ifTrue: ["recording objects to go into an ImageSegment" "remove it from references. Do not trace." refStrm references removeKey: self ifAbsent: []. ^ nil] ! ! !Character methodsFor: '*packageinfo-base' stamp: 'ab 5/31/2003 17:15'! escapeEntities #($< '<' $> '>' $& '&') pairsDo: [:k :v | self = k ifTrue: [^ v]]. ^ String with: self! ! !Character class methodsFor: 'class initialization' stamp: 'yo 10/4/2003 16:03'! initialize "Create the table of unique Characters." " self initializeClassificationTable"! ! !Character class methodsFor: 'class initialization' stamp: 'dgd 8/24/2003 15:10'! initializeClassificationTable " Initialize the classification table. The classification table is a compact encoding of upper and lower cases of characters with - bits 0-7: The lower case value of this character. - bits 8-15: The upper case value of this character. - bit 16: lowercase bit (e.g., isLowercase == true) - bit 17: uppercase bit (e.g., isUppercase == true) " | ch1 ch2 | LowercaseBit := 1 bitShift: 16. UppercaseBit := 1 bitShift: 17. "Initialize the letter bits (e.g., isLetter == true)" LetterBits := LowercaseBit bitOr: UppercaseBit. ClassificationTable := Array new: 256. "Initialize the defaults (neither lower nor upper case)" 0 to: 255 do:[:i| ClassificationTable at: i+1 put: (i bitShift: 8) + i. ]. "Initialize character pairs (upper-lower case)" #( "Basic roman" ($A $a) ($B $b) ($C $c) ($D $d) ($E $e) ($F $f) ($G $g) ($H $h) ($I $i) ($J $j) ($K $k) ($L $l) ($M $m) ($N $n) ($O $o) ($P $p) ($Q $q) ($R $r) ($S $s) ($T $t) ($U $u) ($V $v) ($W $w) ($X $x) ($Y $y) ($Z $z) "International" ($Ä $ä) ($Å $å) ($Ç $ç) ($É $é) ($Ñ $ñ) ($Ö $ö) ($Ü $ü) ($À $à) ($à $ã) ($Õ $õ) ($Œ $œ) ($Æ $æ) "International - Spanish" ($à $á) ($à $í) ($Ó $ó) ($Ú $ú) "International - PLEASE CHECK" ($È $è) ($Ì $ì) ($Ò $ò) ($Ù $ù) ($Ë $ë) ($à $ï) ($ $â) ($Ê $ê) ($Î $î) ($Ô $ô) ($Û $û) ) do:[:pair| ch1 := pair first asciiValue. ch2 := pair last asciiValue. ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch2 + UppercaseBit. ClassificationTable at: ch2+1 put: (ch1 bitShift: 8) + ch2 + LowercaseBit. ]. "Initialize a few others for which we only have lower case versions." #($ß $Ø $ø $ÿ) do:[:char| ch1 := char asciiValue. ClassificationTable at: ch1+1 put: (ch1 bitShift: 8) + ch1 + LowercaseBit. ]. ! ! !Character class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! codePoint: integer "Return a character whose encoding value is integer." #Fundmntl. (0 > integer or: [255 < integer]) ifTrue: [self error: 'parameter out of range 0..255']. ^ CharacterTable at: integer + 1! ! !Character class methodsFor: 'instance creation' stamp: 'yo 8/27/2002 15:15'! value: anInteger "Answer the Character whose value is anInteger." anInteger > 255 ifTrue: [^ MultiCharacter value: anInteger]. ^ CharacterTable at: anInteger + 1. ! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowDown ^ self value: 31! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowLeft ^ self value: 28! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowRight ^ self value: 29! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowUp ^ self value: 30! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! delete ^ self value: 127! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! end ^ self value: 4! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! home ^ self value: 1! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! insert ^ self value: 5! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! pageDown ^ self value: 12! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! pageUp ^ self value: 11! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! max: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock > self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! min: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock < self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'RAA 2/25/2001 14:55'! cr "Answer a CharacterBlock that specifies the current location of the mouse relative to a carriage return stop condition that has just been encountered. The ParagraphEditor convention is to denote selections by CharacterBlocks, sometimes including the carriage return (cursor is at the end) and sometimes not (cursor is in the middle of the text)." ((characterIndex ~= nil and: [characterIndex > text size]) or: [(line last = text size) and: [(destY + line lineHeight) < characterPoint y]]) ifTrue: ["When off end of string, give data for next character" destY _ destY + line lineHeight. lastCharacter _ nil. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY. lastIndex _ lastIndex + 1. self lastCharacterExtentSetX: 0. ^ true]. lastCharacter _ CR. characterPoint _ destX @ destY. self lastCharacterExtentSetX: rightMargin - destX. ^true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex _ characterIndex. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter _ (text at: lastIndex). characterPoint _ destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter _ (text at: line last). characterPoint _ destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex _ lastIndex + 1. lastCharacter _ text at: lastIndex. currentX _ destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint _ currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab _ true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 11/18/2002 13:16'! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | (((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) or: [ ((lastIndex < line last) and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar) and: [lastIndex ~= characterIndex]])]) ifTrue: ["We're really at the end of a real run." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. self setStopConditions. ^false]. lastCharacter _ text at: lastIndex. characterPoint _ destX @ destY. ((lastCharacter = Space and: [alignment = Justified]) or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent]. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [self characterPointSetX: destX - lastCharacterExtent x. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "just off end of line without crossing x" lastIndex _ lastIndex + 1. ^true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:30'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). ! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 12/15/2001 23:28'! tab | currentX | currentX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastSpaceOrTabExtent _ lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^ self crossedX]. destX _ currentX. lastIndex _ lastIndex + 1. ^false! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'BG 5/31/2003 16:08'! buildCharacterBlockIn: para | lineIndex runLength lineStop done stopCondition | "handle nullText" (para numberOfLines = 0 or: [text size = 0]) ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" text: para text topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment])) @ para compositionRectangle top extent: 0 @ textStyle lineGrid]. "find the line" lineIndex _ para lineIndexOfTop: characterPoint y. destY _ para topAtLineIndex: lineIndex. line _ para lines at: lineIndex. lastIndex _ line first. self setStopConditions. " also loads the font and loads all emphasis attributes " rightMargin _ para rightMarginForDisplay. (lineIndex = para numberOfLines and: [(destY + line lineHeight) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" self characterPointSetX: rightMargin] ifFalse: [characterPoint y < (para compositionRectangle) top ifTrue: ["force search to first line" characterPoint _ (para compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [self characterPointSetX: rightMargin]]. destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])). nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]). lastIndex _ line first. self setStopConditions. "also sets font" runLength _ (text runLengthFor: line first). characterIndex == nil ifTrue: [lineStop _ line last "characterBlockAtPoint"] ifFalse: [lineStop _ characterIndex "characterBlockForIndex"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. lastCharacterExtent _ 0 @ line lineHeight. spaceCount _ 0. done _ false. self handleIndentation. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [characterIndex == nil ifTrue: ["characterBlockAtPoint" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent] ifFalse: ["characterBlockForIndex" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent]]]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:32'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" | runLength lineStop done stopCondition | line := textLine. rightMargin := line rightMargin. lastIndex := line first. self setStopConditions. "also sets font" characterIndex := index. " == nil means scanning for point" characterPoint := aPoint. (characterPoint isNil or: [characterPoint y > line bottom]) ifTrue: [characterPoint := line bottomRight]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex notNil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. destX := leftMargin := line leftMarginForAlignment: alignment. destY := line top. runLength := text runLengthFor: line first. characterIndex ifNotNil: [lineStop := characterIndex "scanning for index"] ifNil: [lineStop := line last "scanning for point"]. runStopIndex := lastIndex + (runLength - 1) min: lineStop. lastCharacterExtent := 0 @ line lineHeight. spaceCount := 0. done := false. [done] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth ifNil: [font widthOf: (text at: lastIndex)] ifNotNil: [specialWidth]). (self perform: stopCondition) ifTrue: [characterIndex ifNil: [ "Result for characterBlockAtPoint: " (stopCondition ~~ #cr and: [ lastIndex == line last and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) ifTrue: [ "Correct for right half of last character in line" ^ (CharacterBlock new stringIndex: lastIndex + 1 text: text topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) extent: 0 @ lastCharacterExtent y) textLine: line ]. ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0)) textLine: line] ifNotNil: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent) textLine: line]]]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'hmm 2/2/2001 15:07'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin _ leftMargin. indentationLevel timesRepeat: [ nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth _ anchoredMorph width. ^ true! ! !CharacterBlockScanner commentStamp: '' prior: 0! My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.! !CharacterScanner methodsFor: 'private' stamp: 'ar 12/15/2001 23:31'! setAlignment: style alignment _ style. ! ! !CharacterScanner methodsFor: 'private' stamp: 'yo 10/7/2002 14:33'! setConditionArray: aSymbol aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition copy]. aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy]. aSymbol == nil ifTrue: [^stopConditions _ NilCondition copy]. self error: 'undefined stopcondition for space character'. ! ! !CharacterScanner methodsFor: 'private' stamp: 'tak 3/12/2005 00:43'! setFont | priorFont | "Set the font and other emphasis." priorFont _ font. text == nil ifFalse:[ emphasisCode _ 0. kern _ 0. indentationLevel _ 0. alignment _ textStyle alignment. font _ nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font _ font emphasized: emphasisCode. priorFont ifNotNil: [destX _ destX + priorFont descentKern]. destX _ destX - font descentKern. "NOTE: next statement should be removed when clipping works" leftMargin ifNotNil: [destX _ destX max: leftMargin]. kern _ kern - font baseKern. "Install various parameters from the font." spaceWidth _ font widthOf: Space. xTable _ font xTable. stopConditions _ DefaultStopConditions.! ! !CharacterScanner methodsFor: 'scanning' stamp: 'yo 9/23/2002 16:13'! basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char | lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [char _ (sourceString at: lastIndex). ascii _ char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextDestX _ destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanning' stamp: 'RAA 5/4/2001 13:53'! columnBreak ^true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 01:50'! embeddedObject | savedIndex | savedIndex _ lastIndex. text attributesAt: lastIndex do:[:attr| attr anchoredMorph ifNotNil:[ "Following may look strange but logic gets reversed. If the morph fits on this line we're not done (return false for true) and if the morph won't fit we're done (return true for false)" (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]]. lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs" ^false! ! !CharacterScanner methodsFor: 'scanning' stamp: 'hmm 7/15/2000 22:40'! handleIndentation self indentationLevel timesRepeat: [ self plainTab]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'tak 3/12/2005 00:43'! measureString: aString inFont: aFont from: startIndex to: stopIndex "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" destX _ destY _ lastIndex _ 0. xTable _ aFont xTable. self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. ^destX! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/16/2001 19:27'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." | w | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. destX _ destX + (w _ anchoredMorph width). (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. lastIndex _ lastIndex + 1. self setFont. "Force recalculation of emphasis for next run" ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 12/15/2001 23:28'! plainTab "This is the basic method of adjusting destX for a tab." destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "embedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'yo 12/27/2002 04:32'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | startEncoding selector | (sourceString isKindOf: String) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.]. (sourceString isKindOf: MultiString) ifTrue: [ startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. selector _ (EncodedCharSet charsetAt: startEncoding) scanSelector. ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta). ]. ^ stops at: EndOfRun ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ls 1/14/2002 21:26'! initialize destX _ destY _ leftMargin _ 0.! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ar 12/31/2001 00:52'! initializeStringMeasurer stopConditions _ Array new: 258. stopConditions at: CrossedX put: #crossedX. stopConditions at: EndOfRun put: #endOfRun. ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'RAA 5/7/2001 10:11'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 12:32'! isBreakableAtIndex: index ^ (EncodedCharSet at: ((text at: index) leadingChar + 1)) isBreakableAt: index in: text. ! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/13/2003 11:57'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ maxAscii _ font maxAsciiFor: startEncoding. f _ font fontArray at: startEncoding + 1. "xTable _ f xTable. maxAscii _ xTable size - 2." spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/27/2002 04:33'! scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ maxAscii _ font maxAsciiFor: startEncoding. f _ font fontArray at: startEncoding + 1. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !CharacterScanner commentStamp: '' prior: 0! My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.! !CharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09'! initialize " CharacterScanner initialize " | a | a _ Array new: 258. a at: 1 + 1 put: #embeddedObject. a at: Tab asciiValue + 1 put: #tab. a at: CR asciiValue + 1 put: #cr. a at: EndOfRun put: #endOfRun. a at: CrossedX put: #crossedX. NilCondition _ a copy. DefaultStopConditions _ a copy. PaddedSpaceCondition _ a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. SpaceCondition _ a copy. SpaceCondition at: Space asciiValue + 1 put: #space. ! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'! = anObject ^self species == anObject species and: [ self byteArrayMap = anObject byteArrayMap ]! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:57'! species ^CharacterSet! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'nk 8/3/2004 06:54'! empty "return an empty set of characters" ^self new! ! !CharacterTest methodsFor: 'testing - Class Methods' stamp: 'md 4/18/2003 09:59'! testNew self should: [Character new] raise: Error.! ! !CharacterTest commentStamp: '' prior: 0! This is the unit test for the class Character. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ChatButtonMorph methodsFor: 'event handling' stamp: 'ar 6/4/2001 00:40'! mouseDown: evt oldColor _ self fillStyle. self label: labelDown. self doButtonDownAction. ! ! !ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40'! doButtonDownAction (target notNil and: [actionDownSelector notNil]) ifTrue: [Cursor normal showWhile: [target perform: actionDownSelector]]! ! !ChatButtonMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 18:40'! doButtonUpAction (target notNil and: [actionUpSelector notNil]) ifTrue: [Cursor normal showWhile: [target perform: actionUpSelector]]! ! !ChatNotes methodsFor: 'initialization' stamp: 'mir 11/27/2001 12:01'! loadNotes "Load notes from the files" | dir | names _ OrderedCollection new. notes _ OrderedCollection new. (FileDirectory default directoryExists: 'audio') ifFalse: [^self]. dir _ self audioDirectory. dir fileNames do: [:fname | (fname endsWith: '.name') ifTrue: [ names add: ((dir fileNamed: fname) contentsOfEntireFile). notes add: (fname copyFrom: 1 to: (fname size - 4))]].! ! !ChatNotes methodsFor: 'file i/o' stamp: 'mir 11/27/2001 12:04'! audioDirectory (FileDirectory default directoryExists: 'audio') ifFalse: [FileDirectory default createDirectory: 'audio']. ^FileDirectory default directoryNamed: 'audio'! ! !ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0! ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! !ChronologyConstants class methodsFor: 'as yet unclassified' stamp: 'brp 9/25/2003 10:49'! initialize "ChronologyConstants initialize" SqueakEpoch _ 2415386. "Julian day number of 1 Jan 1901" SecondsInDay _ 86400. SecondsInHour _ 3600. SecondsInMinute _ 60. NanosInSecond _ 10 raisedTo: 9. NanosInMillisecond _ 10 raisedTo: 6. DayNames _ #(Sunday Monday Tuesday Wednesday Thursday Friday Saturday). MonthNames _ #(January February March April May June July August September October November December). DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31). ! ! !Class methodsFor: 'initialize-release' stamp: 'hg 10/30/2001 13:38'! deactivate "A remnant from the 3.3a modules work, retained . Does nothing, but may be overridden in Metaclasses."! ! !Class methodsFor: 'initialize-release' stamp: 'yo 7/15/2003 20:58'! declare: varString "Declare class variables common to all instances. Answer whether recompilation is advisable." | newVars conflicts | newVars _ (Scanner new scanFieldNames: varString) collect: [:x | x asSymbol]. newVars do: [:var | var first canBeGlobalVarInitial ifFalse: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']]. conflicts _ false. classPool == nil ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: [:var | self removeClassVarName: var]]. (newVars reject: [:var | self classPool includesKey: var]) do: [:var | "adding" "check if new vars defined elsewhere" (self bindingOf: var) notNil ifTrue: [self error: var , ' is defined elsewhere'. conflicts _ true]]. newVars size > 0 ifTrue: [classPool _ self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 22:28'! removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self removeFromSystem: true.! ! !Class methodsFor: 'initialize-release' stamp: 'NS 1/16/2004 15:16'! removeFromSystem: logged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." "keep the class name and category for triggering the system change message. If we wait to long, then we get obsolete information which is not what we want." "tell class to deactivate and unload itself-- two separate events in the module system" self deactivate; unload. self superclass ifNotNil: ["If we have no superclass there's nothing to be remembered" self superclass addObsoleteSubclass: self]. self environment forgetClass: self logged: logged. self obsolete.! ! !Class methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 22:29'! removeFromSystemUnlogged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" ^self removeFromSystem: false! ! !Class methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 16:09'! sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools found | oldPools _ self sharedPools. sharedPools _ OrderedCollection new. (Scanner new scanFieldNames: poolString) do: [:poolName | sharedPools add: (self environment at: poolName asSymbol ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[self environment at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. sharedPools isEmpty ifTrue: [sharedPools _ nil]. oldPools do: [:pool | found _ false. self sharedPools do: [:p | p == pool ifTrue: [found _ true]]. found ifFalse: [^ true "A pool got deleted"]]. ^ false! ! !Class methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:32'! superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet "Answer an instance of me, a new class, using the arguments of the message as the needed information. Must only be sent to a new instance; else we would need Object flushCache." superclass _ sup. methodDict _ md. format _ ft. name _ nm. instanceVariables _ nilOrArray. classPool _ pool. sharedPools _ poolSet. self organization: org.! ! !Class methodsFor: 'initialize-release' stamp: 'hg 12/12/2001 12:00'! unload "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses." ! ! !Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'! classPoolFrom: aClass "share the classPool with aClass." classPool := aClass classPool! ! !Class methodsFor: 'class name' stamp: 'sw 12/1/2000 20:39'! externalName "Answer a name by which the receiver can be known." ^ name! ! !Class methodsFor: 'class name' stamp: 'sw 12/18/2000 15:50'! nameForViewer "Answer the name to be shown in the header of a viewer looking at the receiver" ^ self name ifNil: ['Unnamed class']! ! !Class methodsFor: 'class name' stamp: 'NS 1/15/2004 15:41'! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifFalse: [^ self]. (self environment includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. (Undeclared includesKey: newName) ifTrue: [self inform: 'There are references to, ' , aString printString , ' from Undeclared. Check them after this change.']. self environment renameClass: self as: newName. name _ newName! ! !Class methodsFor: 'instance variables' stamp: 'sw 12/26/2003 19:30'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) name: self name inEnvironment: self environment subclassOf: superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString, ' ', aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category ! ! !Class methodsFor: 'class variables' stamp: 'yo 7/2/2004 13:54'! addClassVarName: aString "Add the argument, aString, as a class variable of the receiver. Signal an error if the first character of aString is not capitalized, or if it is already a variable named in the class." | symbol oldState | oldState _ self copy. aString first canBeGlobalVarInitial ifFalse: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.']. symbol _ aString asSymbol. self withAllSubclasses do: [:subclass | (subclass bindingOf: symbol) ifNotNil:[ ^ self error: aString , ' is already used as a variable name in class ' , subclass name]]. classPool == nil ifTrue: [classPool _ Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" classPool declare: symbol from: Undeclared. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! !Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04'! addSharedPool: aSharedPool "Add the argument, aSharedPool, as one of the receiver's shared pools. Create an error if the shared pool is already one of the pools. This method will work with shared pools that are plain Dictionaries or thenewer SharedPool subclasses" (self sharedPools includes: aSharedPool) ifTrue: [^self error: 'This is already in my shared pool list']. sharedPools == nil ifTrue: [sharedPools _ OrderedCollection with: aSharedPool] ifFalse: [sharedPools add: aSharedPool]! ! !Class methodsFor: 'pool variables'! allSharedPools "Answer a Set of the pools the receiver shares, including those defined in the superclasses of the receiver." | aSet | ^ superclass == nil ifTrue: [self sharedPools copy] ifFalse: [aSet _ superclass allSharedPools. aSet addAll: self sharedPools. aSet]! ! !Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:06'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" | aSymbol binding | aSymbol := varName asSymbol. "First look in classVar dictionary." binding := self classPool bindingOf: aSymbol. binding ifNotNil:[^binding]. "Next look in shared pools." self sharedPools do:[:pool | binding := pool bindingOf: aSymbol. binding ifNotNil:[^binding]. ]. "Next look in declared environment." binding := self environment bindingOf: aSymbol. binding ifNotNil:[^binding]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ nil] ifFalse: [^ superclass bindingOf: aSymbol]. ! ! !Class methodsFor: 'compiling' stamp: 'ar 5/17/2003 14:13'! canFindWithoutEnvironment: varName "This method is used for analysis of system structure -- see senders." "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." "First look in classVar dictionary." (self classPool bindingOf: varName) ifNotNil:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool bindingOf: varName) ifNotNil:[^true]. ]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ (superclass bindingOf: varName) notNil]. ! ! !Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24'! possibleVariablesFor: misspelled continuedFrom: oldResults | results | results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results _ misspelled correctAgainstDictionary: pool continuedFrom: results ]. superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] ifFalse: [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! !Class methodsFor: 'subclass creation' stamp: 'sd 3/28/2003 15:24'! newSubclass | i className | i _ 1. [className _ (self name , i printString) asSymbol. self environment includesKey: className] whileTrue: [i _ i + 1]. ^ self subclass: className instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: Object categoryForUniclasses "Point newSubclass new"! ! !Class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:16'! fileOutAsHtml: useHtml "File a description of the receiver onto a new file whose base name is the name of the receiver." | internalStream | internalStream _ WriteStream on: (String new: 100). internalStream header; timeStamp. self sharedPools size > 0 ifTrue: [ self shouldFileOutPools ifTrue: [self fileOutSharedPoolsOn: internalStream]]. self fileOutOn: internalStream moveSource: false toFile: 0. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: useHtml. ! ! !Class methodsFor: 'fileIn/Out' stamp: 'tpr 5/30/2003 13:01'! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | (aPool isKindOf: SharedPool class) ifTrue:[^self notify: 'we do not fileout SharedPool type shared pools for now']. aPoolName _ self environment keyAtIdentityValue: aPool. Transcript cr; show: aPoolName. aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr. aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr. aPool keys asSortedCollection do: [ :aKey | aValue _ aPool at: aKey. aFileStream nextPutAll: aPoolName , ' at: #''' , aKey asString , '''', ' put: '. (aValue isKindOf: Number) ifTrue: [aValue printOn: aFileStream] ifFalse: [aFileStream nextPutAll: '('. aValue printOn: aFileStream. aFileStream nextPutAll: ')']. aFileStream nextPutAll: '!!'; cr]. aFileStream cr! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 3/28/2003 15:24'! fileOutSharedPoolsOn: aFileStream "file out the shared pools of this class after prompting the user about each pool" | poolsToFileOut | poolsToFileOut _ self sharedPools select: [:aPool | (self shouldFileOutPool: (self environment keyAtIdentityValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! ! !Class methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:33'! removeFromChanges "References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet. 7/18/96 sw: call removeClassAndMetaClassChanges:" ChangeSet current removeClassAndMetaClassChanges: self! ! !Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'! spaceUsed "Object spaceUsed" ^ super spaceUsed + self class spaceUsed! ! !Class methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:57'! sunitName ^self name! ! !Class class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:16'! fileOutPool: aString "file out the global pool named aString" | internalStream | internalStream _ WriteStream on: (String new: 1000). self new fileOutPool: (self environment at: aString asSymbol) onFileStream: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: aString isSt: true useHtml: false. ! ! !ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'! doneCompiling: aClass "The receiver has finished modifying the class hierarchy. Do any necessary cleanup." aClass doneCompiling. Behavior flushObsoleteSubclasses.! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:20'! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass needNew copyOfOldClass | environ _ oldClass environment. instVars _ Scanner new scanFieldNames: instVarString. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass or not" needNew _ self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. needNew ifNil:[^nil]. "some error" needNew ifFalse:[^oldClass]. "no new class needed" "Create the new class" copyOfOldClass _ oldClass copy. newClass _ self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. newClass _ self recompile: false from: oldClass to: newClass mutate: false. self doneCompiling: newClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/20/2004 19:46'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass organization instVars classVars force needNew oldCategory copyOfOldClass newCategory | environ _ env. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass _ env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" copyOfOldClass _ oldClass copy. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass" needNew _ self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue:[^nil]. "some error" (needNew and:[unsafe not]) ifTrue:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. needNew ifTrue:[ "Create the new class" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue:[^nil]. "Some error" newClass setName: className. ] ifFalse:[ "Reuse the old class" newClass _ oldClass. ]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." newCategory _ category asSymbol. organization _ environ ifNotNil:[environ organization]. oldClass isNil ifFalse: [oldCategory := (organization categoryOfElement: oldClass name) asSymbol]. organization classify: newClass name under: newCategory. newClass environment: environ. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ [environ at: newClass name put: newClass] on: AttemptToWriteReadOnlyGlobal do:[:ex| ex resume: true]. Smalltalk flushClassNameCache. ]. self doneCompiling: newClass. "... notify interested clients ..." oldClass isNil ifTrue: [ SystemChangeNotifier uniqueInstance classAdded: newClass inCategory: newCategory. ^ newClass]. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. newCategory ~= oldCategory ifTrue: [SystemChangeNotifier uniqueInstance class: newClass recategorizedFrom: oldCategory to: category]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'! needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Answer whether we need a new subclass to conform to the requested changes" | newFormat | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" oldClass ifNil:[^true]. "yes, it's a new class" newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" ^false ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 2/27/2003 22:56'! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass _ self privateNewSubclassOf: newSuper from: oldClass] ifFalse:[newClass _ oldClass clone]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. self recordClass: oldClass replacedBy: newClass. ]. (oldClass == nil or:[oldClass isObsolete not]) ifTrue:[newSuper addSubclass: newClass] ifFalse:[newSuper addObsoleteSubclass: newClass]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:53'! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[^ newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ "Recompile from newClass without mutating" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ newClass isSystemDefined ifFalse:[progress _ nil]. self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'NS 1/21/2004 09:21'! silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass | copyOfSrcClass _ srcClass copy. copyOfDstClass _ dstClass copy. srcVars _ srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars _ srcVars] ifFalse:[dstVars _ dstClass instVarNames]. dstIndex _ dstVars indexOf: prevInstVarName. dstVars _ (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ newClass _ self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ]. newClass _ self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! ! !ClassBuilder methodsFor: 'validation' stamp: 'yo 11/11/2002 10:22'! validateClassName: aString "Validate the new class name" aString first canBeGlobalVarInitial ifFalse:[ self error: 'Class names must be capitalized'. ^false]. environ at: aString ifPresent:[:old| (old isKindOf: Behavior) ifFalse:[ self notify: aString asText allBold, ' already exists!!\Proceed will store over it.' withCRs]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ajh 10/17/2002 11:10'! validateInstvars: instVarArray from: oldClass forSuper: newSuper "Check if any of the instVars of oldClass conflict with the new superclass" | instVars usedNames temp | instVarArray isEmpty ifTrue:[^true]. "Okay" newSuper allowsSubInstVars ifFalse: [ self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ^ false]. "Validate the inst var names" usedNames _ instVarArray asSet. usedNames size = instVarArray size ifFalse:[ instVarArray do:[:var| usedNames remove: var ifAbsent:[temp _ var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp _ var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames _ newSuper allInstVarNames asSet. instVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl instVarNames includes: iv) ifTrue:[temp _ cl]]. self error: iv,' is already defined in ', temp name. ^false]]]. oldClass == nil ifFalse:[ usedNames _ Set new: 20. oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames]. instVars _ instVarArray. newSuper == nil ifFalse:[instVars _ instVars, newSuper allInstVarNames]. instVars do:[:iv| (usedNames includes: iv) ifTrue:[ self error: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:13'! validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType "Returns whether the immediate subclasses of oldClass can keep its layout" "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" "isWeak implies isVariant" (oldClass isVariable and: [ subclass isWeak ]) ifFalse: [ "In general we discourage format mis-matches" (subclass typeOfClass == newType) ifFalse: [ self error: subclass name,' cannot be recompiled'. ^ false ]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19'! validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize "Validate the # of instVars and the format of the subclasses" | deltaSize | oldClass == nil ifTrue: [^ true]. "No subclasses" "Compute the # of instvars needed for all subclasses" deltaSize _ newInstSize. (oldClass notNil) ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size]. (newSuper notNil) ifTrue: [deltaSize _ deltaSize + newSuper instSize]. (oldClass notNil and: [oldClass superclass notNil]) ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize]. (oldClass == nil) ifTrue: [ (deltaSize > 254) ifTrue: [ self error: 'More than 254 instance variables'. ^ false]. ^ true]. oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) ifTrue: [ self error: sub name,' has more than 254 instance variables'. ^ false]. "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." (newType ~~ #normal) ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. ^ true! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! privateNewSubclassOf: newSuper "Create a new meta and non-meta subclass of newSuper" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta newMeta | newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta _ Metaclass new. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: newSuperMeta format. ^newMeta new ! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! privateNewSubclassOf: newSuper from: oldClass "Create a new meta and non-meta subclass of newSuper using oldClass as template" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta oldMeta newMeta | oldClass ifNil:[^self privateNewSubclassOf: newSuper]. newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. oldMeta _ oldClass class. newMeta _ oldMeta clone. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Record the meta class change" self recordClass: oldMeta replacedBy: newMeta. "And create a new instance" ^newMeta adoptInstance: oldClass from: oldMeta! ! !ClassBuilder methodsFor: 'private' stamp: 'NS 1/27/2004 14:21'! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ SystemChangeNotifier uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'gk 2/28/2005 16:35'! reservedNames "Return a list of names that must not be used for variables" ^#('self' 'super' 'thisContext' 'true' 'false' 'nil' self super thisContext #true #false #nil).! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 3/5/2001 12:00'! showProgressFor: aClass "Announce that we're processing aClass" progress == nil ifTrue:[^self]. aClass isObsolete ifTrue:[^self]. currentClassIndex _ currentClassIndex + 1. (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: [progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')]! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 22:44'! mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." | newSubclass | self showProgressFor: oldClass. "Convert the subclasses" oldClass subclasses do:[:oldSubclass| newSubclass _ self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. "And any obsolete ones" oldClass obsoleteSubclasses do:[:oldSubclass| oldSubclass ifNotNil:[ newSubclass _ self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. ]. ]. self update: oldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'! reshapeClass: oldClass toSuper: newSuper "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." | instVars | "ar 9/22/2002: The following is a left-over from some older code. I do *not* know why we uncompact oldClass here. If you do, then please let me know so I can put a comment here..." oldClass becomeUncompact. instVars _ instVarMap at: oldClass name ifAbsent:[oldClass instVarNames]. ^self newSubclassOf: newSuper type: oldClass typeOfClass instanceVariables: instVars from: oldClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42'! update: oldClass to: newClass "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. We can rely on two assumptions (which are critical): #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. " | meta | meta _ oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." [ "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue:[oldClass becomeForward: newClass] ifFalse:[(Array with: oldClass with: oldClass class) elementsForwardIdentityTo: (Array with: newClass with: newClass class)]. Smalltalk garbageCollect. "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." ] valueUnpreemptively. ! ! !ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0! Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. Implementation notes: ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM. ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" Utilities informUserDuring:[:bar| self checkClassHierarchyConsistency: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:03'! checkClassHierarchyConsistency: informer "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" | classes | Transcript cr; show: 'Start checking the class hierarchy...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Validating class hierarchy ', (index * 100 // classes size) printString,'%'. meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. self checkClassHierarchyConsistencyFor: meta. ]. Transcript show: 'OK'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'! checkClassHierarchyConsistencyFor: aClassDescription "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete subclasses" | mySuperclass | mySuperclass _ aClassDescription superclass. (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete ifTrue: [self error: 'Something wrong!!']. mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. aClassDescription subclasses do: [:each | each isObsolete ifTrue: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ]. aClassDescription obsoleteSubclasses do: [:each | each isObsolete ifFalse: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:00'! cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Utilities informUserDuring:[:bar| self cleanupAndCheckClassHierarchy: bar. ]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 15:58'! cleanupAndCheckClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." Transcript cr; show: '*** Before cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses. self cleanupClassHierarchy: informer. self checkClassHierarchyConsistency: informer. Transcript cr; cr; show: '*** After cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:04'! cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." Utilities informUserDuring:[:bar| self cleanupClassHierarchy: bar. ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'ar 4/23/2002 16:02'! cleanupClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." | classes | Transcript cr; show: 'Start fixing the class hierarchy and cleaning up...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer value:'Fixing class hierarchy ', (index * 100 // classes size) printString,'%'. "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. self cleanupClassHierarchyFor: meta. ]. Transcript show: 'DONE'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 5/8/2002 10:55'! cleanupClassHierarchyFor: aClassDescription | myName mySuperclass | mySuperclass _ aClassDescription superclass. (self isReallyObsolete: aClassDescription) ifTrue: [ "Remove class >>>from SystemDictionary if it is obsolete" myName _ aClassDescription name asString. Smalltalk keys asArray do: [:each | (each asString = myName and: [(Smalltalk at: each) == aClassDescription]) ifTrue: [Smalltalk removeKey: each]]. "Make class officially obsolete if it is not" (aClassDescription name asString beginsWith: 'AnObsolete') ifFalse: [aClassDescription obsolete]. aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. "Add class to obsoleteSubclasses of its superclass" mySuperclass ifNil: [self error: 'Obsolete subclasses of nil cannot be stored']. (mySuperclass obsoleteSubclasses includes: aClassDescription) ifFalse: [mySuperclass addObsoleteSubclass: aClassDescription]. ] ifFalse:[ "check if superclass has aClassDescription in its obsolete subclasses" mySuperclass ifNil:[mySuperclass _ Class]. "nil subclasses" mySuperclass removeObsoleteSubclass: aClassDescription. ]. "And remove its obsolete subclasses if not actual superclass" aClassDescription obsoleteSubclasses do:[:obs| obs superclass == aClassDescription ifFalse:[ aClassDescription removeObsoleteSubclass: obs]]. ! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! countReallyObsoleteClassesAndMetaclasses "Counting really obsolete classes and metaclasses" | metaSize classSize | Smalltalk garbageCollect. metaSize _ self reallyObsoleteMetaclasses size. Transcript cr; show: 'Really obsolete metaclasses: ', metaSize printString. classSize _ self reallyObsoleteClasses size. Transcript cr; show: 'Really obsolete classes: ', classSize printString; cr. "Metaclasses must correspond to classes!!" metaSize ~= classSize ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! isReallyObsolete: aClassDescription "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete isObsolete does not always return the right answer" ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteClasses | obsoleteClasses | obsoleteClasses _ OrderedCollection new. Metaclass allInstances do: [:meta | meta allInstances do: [:each | (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. ^ obsoleteClasses! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteMetaclasses ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:49'! baseClassName ^'TestClassForClassChangeTest'! ! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:51'! cleanup baseClass ifNotNil:[baseClass removeFromSystem].! ! !ClassBuilderChangeClassTypeTest methodsFor: 'testing' stamp: 'BG 1/6/2004 00:04'! testClassCreationAndChange | success | [baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. self assert: baseClass isPointers. self deny: baseClass isVariable. success := true. [Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'.] on: Error do: [:exception | success := false]. self assert: (success and: [baseClass isVariable]). ] ensure: [self cleanup] ! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! baseClassName ^#DummyClassBuilderFormatTestSuperClass! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! cleanup subClass ifNotNil:[subClass removeFromSystem]. baseClass ifNotNil:[baseClass removeFromSystem].! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeByteVariableSubclassOf: aClass subClass := aClass variableByteSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeIVarsSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: 'var3 var4' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeNormalSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! makeVariableSubclassOf: aClass subClass := aClass variableSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'.! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! makeWeakSubclassOf: aClass subClass := aClass weakSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! makeWordVariableSubclassOf: aClass subClass := aClass variableWordSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! subClassName ^#DummyClassBuilderFormatTestSubClass! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! testByteVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableByteSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self assert:(subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:21'! testSubclassWithInstanceVariables "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: 'var1 var2' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testWeakSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object weakSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'ar 1/4/2004 20:20'! testWordVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableWordSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder'. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! theClass ^ class! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'sw 4/3/2001 14:16'! noteChangeType: changeSymbol fromClass: class (changeSymbol = #new or: [changeSymbol = #add]) ifTrue: [changeTypes add: #add. changeTypes remove: #change ifAbsent: []. revertable _ false. ^ self]. changeSymbol = #change ifTrue: [(changeTypes includes: #add) ifTrue: [^ self]. ^ changeTypes add: changeSymbol]. changeSymbol == #addedThenRemoved ifTrue: [^ self]. "An entire class was added but then removed" changeSymbol = #comment ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #reorganize ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #rename ifTrue: [^ changeTypes add: changeSymbol]. (changeSymbol beginsWith: 'oldName: ') ifTrue: ["Must only be used when assimilating other changeSets" (changeTypes includes: #add) ifTrue: [^ self]. priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. ^ changeTypes add: #rename]. changeSymbol = #remove ifTrue: [(changeTypes includes: #add) ifTrue: [changeTypes add: #addedThenRemoved] ifFalse: [changeTypes add: #remove]. ^ changeTypes removeAllFoundIn: #(add change comment reorganize)]. self error: 'Unrecognized changeType'! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'! thisName ^ thisName! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'sw 8/14/2002 11:11'! removeSelector: selector "Remove all memory of changes associated with the argument, selector, in this class." selector == #Comment ifTrue: [changeTypes remove: #comment ifAbsent: []] ifFalse: [methodChanges removeKey: selector ifAbsent: []]! ! !ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'sw 7/31/2002 10:40'! scanFrom: aStream "File in the class comment from aStream. Not string-i-fied, just a text, exactly as it is in the browser. Move to changes file." class theNonMetaClass classComment: (aStream nextChunkText) stamp: changeStamp "Writes it on the disk and saves a RemoteString ref"! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:33'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change s1 s2 | listIndex = 0 ifTrue: [^ self]. change _ changeList at: listIndex. s1 _ classOfMethod organization classComment. s2 _ change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod prettyDiffs: self showingPrettyDiffs)) openLabel: 'Comparison to Current Version'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:02'! offerVersionsHelp (StringHolder new contents: self versionsHelpString) openLabel: 'Class Comment Versions Browsers'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'sd 4/16/2003 08:52'! openSingleMessageBrowser | mr | "Create and schedule a message list browser populated only by the currently selected message" mr _ MethodReference new setStandardClass: self selectedClass methodSymbol: #Comment. self systemNavigation browseMessageList: (Array with: mr) name: mr asStringOrText autoSelect: nil! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:53'! versionsMenu: aMenu "Fill aMenu with menu items appropriate to the receiver" Smalltalk isMorphic ifTrue: [aMenu title: 'versions'. aMenu addStayUpItemSpecial]. ^ aMenu addList: #( ('compare to current' compareToCurrentVersion 'compare selected version to the current version') ('revert to selected version' fileInSelections 'resubmit the selected version, so that it becomes the current version') ('remove from changes' removeMethodFromChanges 'remove this method from the current change set, if present') ('edit current method (O)' openSingleMessageBrowser 'open a single-message browser on the current version of this method') - ('toggle diffing (D)' toggleDiffing 'toggle whether or not diffs should be shown here') ('update list' reformulateList 'reformulate the list of versions, in case it somehow got out of synch with reality') - ('help...' offerVersionsHelp 'provide an explanation of the use of this tool')) ! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 22:26'! diffedVersionContents "Answer diffed version contents, maybe pretty maybe not" | change class earlier later | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. change _ changeList at: listIndex. later _ change text. class _ self selectedClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ later]. earlier _ (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 21:28'! reformulateList classOfMethod organization classComment ifNil: [^ self]. self scanVersionsOf: classOfMethod. self changed: #list. "for benefit of mvc" listIndex _ 1. self changed: #listIndex. self contentsChanged! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 1/3/2003 16:06'! scanVersionsOf: class "Scan for all past versions of the class comment of the given class" | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | classOfMethod _ class. oldCommentRemoteStr _ class organization commentRemoteStr. currentCompiledMethod _ oldCommentRemoteStr. selectorOfMethod _ #Comment. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. sourceFilesCopy _ SourceFiles collect: [:x | x isNil ifTrue: [ nil ] ifFalse: [x readOnlyCopy]]. position _ oldCommentRemoteStr position. file _ sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). " Skip back to before the preamble" [file position < (position-1)] "then pick it up from the front" whileTrue: [preamble _ file nextChunk]. prevPos _ nil. stamp _ ''. (preamble findString: 'commentStamp:' startingAt: 1) > 0 ifTrue: [tokens _ Scanner new scanTokens: preamble. (tokens at: tokens size-3) = #commentStamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokens size-2. prevPos _ tokens last. prevFileIndex _ sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos]] ifFalse: ["The stamp get lost, maybe after a condenseChanges" stamp _ '']. self addItem: (ChangeRecord new file: file position: position type: #classComment class: class name category: nil meta: class stamp: stamp) text: stamp , ' ' , class name , ' class comment'. prevPos = 0 ifTrue:[prevPos _ nil]. position _ prevPos. prevPos notNil ifTrue:[file _ sourceFilesCopy at: prevFileIndex]]. sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. listSelections _ Array new: list size withAll: false! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'asm 8/13/2002 21:33'! updateListsAndCodeIn: aWindow | aComment | aComment _ classOfMethod organization commentRemoteStr. aComment == currentCompiledMethod ifFalse: ["Do not attempt to formulate if there is no source pointer. It probably means it has been recompiled, but the source hasn't been written (as during a display of the 'save text simply?' confirmation)." aComment last ~= 0 ifTrue: [self reformulateList]]. ^ true ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'! classCommentIndicated "Answer whether the receiver is pointed at a class comment" ^ true! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:38'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version'))! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 22:14'! priorSourceOrNil "If the currently-selected method has a previous version, return its source, else return nil" | aClass aSelector changeRecords | (aClass _ self selectedClass) ifNil: [^ nil]. (aSelector _ self selectedMessageName) ifNil: [^ nil]. changeRecords _ self class commentRecordsOf: self selectedClass. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. ^ (changeRecords at: 2) string ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 20:59'! selectedClass "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" ^ classOfMethod! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:35'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ false! ! !ClassCommentVersionsBrowser commentStamp: 'asm 8/13/2002 23:20' prior: 0! A class-comment-versions-browser tool! !ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'asm 8/12/2002 22:46'! browseCommentOf: class | changeList | Cursor read showWhile: [changeList _ self new scanVersionsOf: class. changeList ifNil: [^ self inform: 'No versions available']. self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] ! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'asm 8/13/2002 22:09'! commentRecordsOf: aClass "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." | aList | aList _ self new scanVersionsOf: aClass. ^ aList ifNotNil: [aList changeList]! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'asm 8/13/2002 20:54'! timeStampFor: aSelector class: aClass reverseOrdinal: anInteger "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." | aChangeList | aChangeList _ self new scanVersionsOf: aClass. ^ aChangeList ifNil: [nil] ifNotNil: [aChangeList list size >= anInteger ifTrue: [(aChangeList changeList at: anInteger) stamp] ifFalse: [nil]]! ! !ClassCommentVersionsBrowser class methodsFor: 'window color' stamp: 'asm 8/13/2002 20:57'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Class Comment Versions Browser' brightColor: #(0.769 0.653 1.0) pastelColor: #(0.819 0.753 1.0) helpMessage: 'A tool for viewing prior versions of a class comment.'! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:32'! obsolete "Make the receiver obsolete." superclass removeSubclass: self. self organization: nil. super obsolete.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/6/2004 15:31'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. instanceVariables _ nil. self organization: nil.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'! updateInstances: oldInstances from: oldClass isMeta: isMeta "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | oldInstances isEmpty ifTrue:[^#()]. "no instances to convert" isMeta ifTrue: [ oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. self soleInstance class == self ifTrue:[ ^self error:'Metaclasses can only have one instance']]. map _ self instVarMappingFrom: oldClass. variable _ self isVariable. instSize _ self instSize. newInstances _ Array new: oldInstances size. 1 to: oldInstances size do:[:i| newInstances at: i put: ( self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" oldInstances elementsExchangeIdentityWith: newInstances. ^newInstances "which are now old"! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 20:48'! updateInstancesFrom: oldClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary. Return the array of old instances (none of which should be pointed to legally by anyone but the array)." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" | oldInstances | oldInstances _ oldClass allInstances asArray. oldInstances _ self updateInstances: oldInstances from: oldClass isMeta: self isMeta. "Now fix up instances in segments that are out on the disk." ImageSegment allSubInstancesDo: [:seg | seg segUpdateInstancesOf: oldClass toBe: self isMeta: self isMeta]. ^oldInstances " | crashingBlock class | class _ Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar _ value'. class compile:'crashingBlock ^[instVar]'. crashingBlock _ (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock. crashingBlock value. " ! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 23:57'! classVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. 8/17/96 tk" "This method allows you to distinguish between class versions when the shape of the class hasn't changed (when there's no change in the instVar names). In the conversion methods you usually can tell by the inst var names what old version you have. In a few cases, though, the same inst var names were kept but their interpretation changed (like in the layoutFrame). By changing the class version when you keep the same instVars you can warn older and newer images that they have to convert." ^ 0! ! !ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54'! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText.! ! !ClassDescription methodsFor: 'accessing' stamp: 'NS 1/27/2004 14:54'! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp.! ! !ClassDescription methodsFor: 'accessing' stamp: 'ls 10/28/2003 12:32'! hasComment "return whether this class truly has a comment other than the default" | org | org := self theNonMetaClass organization. ^org classComment notNil and: [ org classComment isEmpty not ]. ! ! !ClassDescription methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:50'! theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self class! ! !ClassDescription methodsFor: 'copying' stamp: 'NS 4/6/2004 15:31'! copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver" methodDict _ donorClass copyOfMethodDictionary. self organization: donorClass organization deepCopy.! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:21'! classVariablesString "Answer a string of my class variable names separated by spaces." ^String streamContents: [ :stream | self classPool keys asSortedCollection do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:20'! instanceVariablesString "Answer a string of my instance variable names separated by spaces." ^String streamContents: [ :stream | self instVarNames do: [ :each | stream nextPutAll: each ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'printing' stamp: 'lr 11/24/2003 17:24'! sharedPoolsString "Answer a string of my shared pool names separated by spaces." ^String streamContents: [ :stream | self sharedPools do: [ :each | stream nextPutAll: (self environment keyAtIdentityValue: each ifAbsent: [ 'private' ]) ] separatedBy: [ stream space ] ]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'nb 6/17/2003 12:25'! chooseClassVarName "Present the user with a list of class variable names and answer the one selected, or nil if none" | lines labelStream vars allVars index | lines _ OrderedCollection new. allVars _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). self withAllSuperclasses reverseDo: [:class | vars _ class classVarNames asSortedCollection. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream contents isEmpty ifTrue: [^Beeper beep]. "handle nil superclass better" labelStream skip: -1 "cut last CR". index _ (PopUpMenu labels: labelStream contents lines: lines) startUp. index = 0 ifTrue: [^ nil]. ^ allVars at: index! ! !ClassDescription methodsFor: 'instance variables' stamp: 'sw 3/20/2001 20:51'! classThatDefinesClassVariable: classVarName "Answer the class that defines the given class variable" (self classPool includesKey: classVarName asSymbol) ifTrue: [^ self]. ^ superclass ifNotNil: [superclass classThatDefinesClassVariable: classVarName]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'NS 1/27/2004 11:49'! renameSilentlyInstVar: old to: new | i oldName newName | oldName _ old asString. newName _ new asString. (i _ instanceVariables indexOf: oldName) = 0 ifTrue: [self error: oldName , ' is not defined in ', self name]. self allSuperclasses , self withAllSubclasses asOrderedCollection do: [:cls | (cls instVarNames includes: newName) ifTrue: [self error: newName , ' is already used in ', cls name]]. instanceVariables replaceFrom: i to: i with: (Array with: newName). self replaceSilently: oldName to: newName. "replace in text body of all methods"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:12'! addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. SystemChangeNotifier uniqueInstance doSilently: [self organization classify: selector under: category]. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 1/28/2004 14:10'! addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil _ self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 1/5/2001 06:53'! allMethodCategoriesIntegratedThrough: mostGenericClass "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | (aClass includesBehavior: mostGenericClass) ifTrue: [aColl addAll: aClass organization categories]]. aColl remove: 'no messages' asSymbol ifAbsent: []. ^ (aColl asSet asSortedCollection: [:a :b | a asLowercase < b asLowercase]) asArray "ColorTileMorph allMethodCategoriesIntegratedThrough: TileMorph"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 4/18/2003 10:26'! allMethodsInCategory: aName "Answer a list of all the method categories of the receiver and all its superclasses " | aColl | aColl _ OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asSortedArray "TileMorph allMethodsInCategory: #initialization"! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 12/11/2000 14:00'! isUniClass "Answer whether the receiver is a uniclass." ^ self name endsWithDigit! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sw 3/20/2001 13:26'! namedTileScriptSelectors "Answer a list of all the selectors of named tile scripts. Initially, only Player reimplements, but if we switch to a scheme in which every class can have uniclass subclasses, this would kick in elsewhere" ^ OrderedCollection new! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'di 3/7/2001 17:05'! recoverFromMDFault "This method handles methodDict faults to support, eg, discoverActiveClasses (qv)." (organization isMemberOf: Array) ifFalse: [^ self error: 'oops']. methodDict _ organization first. organization _ organization second. ! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'sd 3/28/2003 15:32'! recoverFromMDFaultWithTrace "This method handles emthodDict faults to support, eg, discoverActiveClasses (qv)." self recoverFromMDFault. self environment at: #MDFaultDict ifPresent: [:faultDict | faultDict at: self name put: (String streamContents: [:strm | (thisContext stackOfSize: 20) do: [:item | strm print: item; cr]])] "Execute the following statement to induce MD fault tracing. This means that, not only will all active classes be recorded but, after a test run, MDFaultDict will contain, for every class used, a stack trace showing how it came to be used. This statement should be executed just prior to any such text, in order to clear the traces. Smalltalk at: #MDFaultDict put: Dictionary new. "! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'NS 4/7/2004 13:33'! removeSelector: selector | priorMethod priorProtocol | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." priorMethod _ self compiledMethodAt: selector ifAbsent: [^ nil]. priorProtocol _ self whichCategoryIncludesSelector: selector. SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: selector]. super removeSelector: selector. SystemChangeNotifier uniqueInstance methodRemoved: priorMethod selector: selector inProtocol: priorProtocol class: self.! ! !ClassDescription methodsFor: 'organization' stamp: 'nk 8/30/2004 07:48'! category: cat "Categorize the receiver under the system category, cat, removing it from any previous categorization." | oldCat | oldCat := self category. (cat isString) ifTrue: [SystemOrganization classify: self name under: cat asSymbol] ifFalse: [self errorCategoryName]. SystemChangeNotifier uniqueInstance class: self recategorizedFrom: oldCat to: cat asSymbol! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/7/2004 13:33'! forgetDoIts "get rid of old DoIt methods and bogus entries in the ClassOrganizer." SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: #DoIt; removeElement: #DoItIn:. ]. super forgetDoIts.! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:46'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [self organization: (ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray)]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFaultWithTrace]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [organization setSubject: self]. ^ organization! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:26'! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization _ aClassOrg! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/6/2004 15:30'! zapOrganization "Remove the organization of this class by message categories. This is typically done to save space in small systems. Classes and methods created or filed in subsequently will, nonetheless, be organized" self organization: nil. self isMeta ifFalse: [self class zapOrganization]! ! !ClassDescription methodsFor: 'compiling' stamp: 'di 5/4/2001 11:35'! compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:25'! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode _ self basicCompile: text asString notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. logSource ifTrue: [ self logMethodSource: text forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self theNonMetaClass noteCompilationOf: methodAndNode selector meta: self isMeta. ^ methodAndNode selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ self compileSilently: code classified: category notifying: nil.! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:45'! compileSilently: code classified: category notifying: requestor "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." ^ SystemChangeNotifier uniqueInstance doSilently: [self compile: code classified: category withStamp: nil notifying: requestor logSource: false].! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 9/25/2001 02:11'! noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"! ! !ClassDescription methodsFor: 'compiling' stamp: 'NS 1/28/2004 14:48'! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism. 7/12/96 sw" ^ true! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/8/1998 14:44'! classComment: aString "Store the comment, aString or Text or RemoteString, associated with the class we are orgainzing. Empty string gets stored only if had a non-empty one before." ^ self classComment: aString stamp: ''! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:35'! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [SystemChangeNotifier uniqueInstance classCommented: self. ^ self organization classComment: aString stamp: aStamp]. oldCommentRemoteStr _ self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr == nil) ifTrue: [^ self organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr _ oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(file _ SourceFiles at: 2) ifNotNil: [file setToEnd; cr; nextPut: $!!. "directly" "Should be saying (file command: 'H3') for HTML, but ignoring it here" header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. self organization classComment: (RemoteString newString: aString onFileNumber: 2) stamp: aStamp. SystemChangeNotifier uniqueInstance classCommented: self. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'! definitionST80 "Answer a String that defines the receiver." | aStream path | aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [path _ ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path _ remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutAll: self kindOfSubclass; store: self name. aStream cr; tab; nextPutAll: 'instanceVariableNames: '; store: self instanceVariablesString. aStream cr; tab; nextPutAll: 'classVariableNames: '; store: self classVariablesString. aStream cr; tab; nextPutAll: 'poolDictionaries: '; store: self sharedPoolsString. aStream cr; tab; nextPutAll: 'category: '; store: (SystemOrganization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass: nil'. ]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'ls 10/9/2001 00:12'! definitionST80: isST80 "Answer a String that defines the receiver." | aStream path | isST80 ifTrue: [^ self definitionST80]. aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [path _ ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path _ remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutKeyword: self kindOfSubclass withArg: self name. aStream cr; tab; nextPutKeyword: 'instanceVariableNames: ' withArg: self instanceVariablesString. aStream cr; tab; nextPutKeyword: 'classVariableNames: 'withArg: self classVariablesString. aStream cr; tab; nextPutKeyword: 'poolDictionaries: ' withArg: self sharedPoolsString. aStream cr; tab; nextPutKeyword: 'category: ' withArg: (SystemOrganization categoryOfElement: self name) asString. superclass ifNil: [ aStream nextPutAll: '.'; cr. aStream nextPutAll: self name. aStream space; nextPutAll: 'superclass (nil)'. ]. ^ aStream contents! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:16'! fileOutCategory: catName asHtml: useHtml "FileOut the named category, possibly in Html format." | internalStream | internalStream _ WriteStream on: (String new: 1000). internalStream header; timeStamp. self fileOutCategory: catName on: internalStream moveSource: false toFile: 0. internalStream trailer. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , catName) isSt: true useHtml: useHtml. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:36'! fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File all historical description of the messages of this class that have been changed (i.e., are entered into the argument, aSet) onto aFileStream. If moveSource, is true, then set the method source pointer to the new file position. Note when this method is called with moveSource=true, it is condensing the .changes file, and should only write a preamble for every method." | org sels | (org _ self organization) categories do: [:cat | sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]]! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 20:16'! fileOutMethod: selector asHtml: useHtml "Write source code of a single method on a file in .st or .html format" | internalStream | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. internalStream _ WriteStream on: (String new: 1000). internalStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: internalStream moveSource: false toFile: 0. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: useHtml. ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 1/2/2003 21:50'! moveChangesTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sumim 9/2/2003 14:37'! moveChangesWithVersionsTo: newFile "Used in the process of condensing changes, this message requests that the source code of all methods of the receiver that have been changed should be moved to newFile." | changes | changes _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessagesHistorically: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 8/13/2004 02:14'! printMethodChunk: selector withPreamble: doPreamble on: outStream moveSource: moveSource toFile: fileIndex "Copy the source code for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method oldPos newPos sourceFile endPos | doPreamble ifTrue: [preamble _ self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString] ifFalse: [preamble _ '']. method _ self methodDict at: selector ifAbsent: [outStream nextPutAll: selector; cr. outStream tab; nextPutAll: '** ERROR!! THIS SCRIPT IS MISSING ** ' translated; cr; cr. outStream nextPutAll: ' '. ^ outStream]. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [(oldPos _ method filePosition) = 0]) ifTrue: ["The source code is not accessible. We must decompile..." preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. outStream nextChunkPut: (self decompilerClass new decompile: selector in: self method: method) decompileString] ifFalse: [sourceFile _ SourceFiles at: method fileIndex. preamble size > 0 ifTrue: "Copy the preamble" [outStream copyPreamble: preamble from: sourceFile at: oldPos] ifFalse: [sourceFile position: oldPos]. "Copy the method chunk" newPos _ outStream position. outStream copyMethodChunkFrom: sourceFile. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. moveSource ifTrue: "Set the new method source pointer" [endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. ^ outStream cr! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 17:10'! printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method newPos sourceFile endPos category changeList prior | category _ self organization categoryOfElement: selector. preamble _ self name , ' methodsFor: ', category asString printString. method _ self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [method filePosition = 0]) ifTrue: [ outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: ( self decompilerClass new decompile: selector in: self method: method) decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [ changeList _ (VersionsBrowser new scanVersionsOf: method class: self meta: self isMeta category: category selector: selector) changeList. newPos _ nil. sourceFile _ SourceFiles at: method fileIndex. changeList reverseDo: [ :chgRec | chgRec fileIndex = fileIndex ifTrue: [ outStream copyPreamble: preamble from: sourceFile at: chgRec position. (prior _ chgRec prior) ifNotNil: [ outStream position: outStream position - 2. outStream nextPutAll: ' prior: ', ( prior first = method fileIndex ifFalse: [prior third] ifTrue: [ SourceFiles sourcePointerFromFileIndex: method fileIndex andPosition: newPos]) printString. outStream nextPut: $!!; cr]. "Copy the method chunk" newPos _ outStream position. outStream copyMethodChunkFrom: sourceFile at: chgRec position. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. outStream nextChunkPut: ' '; cr]]. moveSource ifTrue: [ endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. ^ outStream! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/8/2004 11:32'! putClassCommentToCondensedChangesFile: aFileStream "Called when condensing changes. If the receiver has a class comment, and if that class comment does not reside in the .sources file, then write it to the given filestream, with the resulting RemoteString being reachable from the source file #2. Note that any existing backpointer into the .sources file is lost by this process -- a situation that maybe should be fixed someday." | header aStamp aCommentRemoteStr | self isMeta ifTrue: [^ self]. "bulletproofing only" ((aCommentRemoteStr _ self organization commentRemoteStr) isNil or: [aCommentRemoteStr sourceFileNumber == 1]) ifTrue: [^ self]. aFileStream cr; nextPut: $!!. header _ String streamContents: [:strm | strm nextPutAll: self name; nextPutAll: ' commentStamp: '. (aStamp _ self organization commentStamp ifNil: ['']) storeOn: strm. strm nextPutAll: ' prior: 0']. aFileStream nextChunkPut: header. aFileStream cr. self organization classComment: (RemoteString newString: self organization classComment onFileNumber: 2 toFile: aFileStream) stamp: aStamp! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 23:01'! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" ^self organization! ]style[(10 156 22 38)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'private' stamp: 'NS 1/28/2004 14:22'! logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor | priorMethodOrNil newText | priorMethodOrNil := self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []. newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not and: [Preferences confirmFirstUseOfStyle]) ifTrue: [aText askIfAddStyle: priorMethodOrNil req: requestor] ifFalse: [aText]. aCompiledMethodWithNode method putSource: newText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: priorMethodOrNil.! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'dtl 8/26/2004 11:02'! commentInventory "Answer a string with a count of the classes with and without comments for all the classes in the package of which this class is a member." "Morph commentInventory" ^ SystemOrganization commentInventory: (self category copyUpTo: $-), '*'! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'sd 3/28/2003 15:32'! removeUninstantiatedSubclassesSilently "Remove the classes of any subclasses that have neither instances nor subclasses. Answer the number of bytes reclaimed" "Player removeUninstantiatedSubclassesSilently" | candidatesForRemoval oldFree | oldFree _ self environment garbageCollect. candidatesForRemoval _ self subclasses select: [:c | (c instanceCount = 0) and: [c subclasses size = 0]]. candidatesForRemoval do: [:c | c removeFromSystem]. ^ self environment garbageCollect - oldFree! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 17:59'! categoryFromUserWithPrompt: aPrompt "SystemDictionary categoryFromUserWithPrompt: 'testing'" self deprecated: 'Use CodeHolder>>categoryFromUserWithPrompt: aPrompt for: aClass instead'. "this deprecation helps to remove UI dependency from the core of Squeak. Normally only CodeHolder was calling this method" CodeHolder new categoryFromUserWithPrompt: aPrompt for: self! ! !ClassDescription methodsFor: 'deprecated' stamp: 'avi 2/17/2004 01:59'! compileInobtrusively: code classified: category "Compile the code and classify the resulting method in the given category, leaving no trail in the system log, nor in any change set, nor in the 'recent submissions' list. This should only be used when you know for sure that the compilation will succeed." | methodNode newMethod | self deprecated: 'Use compileSilently:classified: instead.'. methodNode _ self compilerClass new compile: code in: self notifying: nil ifFail: [^ nil]. self addSelectorSilently: methodNode selector withMethod: (newMethod _ methodNode generate: #(0 0 0 0)). SystemChangeNotifier uniqueInstance doSilently: [self organization classify: methodNode selector under: category]. ^ newMethod! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:43'! compileProgrammatically: code classified: cat "compile the given code programmatically. In the current theory, we always do this unlogged as well, and do not accumulate the change in the current change set" self deprecated: 'Use compileSilently:classified: instead.'. ^ self compileSilently: code classified: cat " | oldInitials | oldInitials _ Utilities authorInitialsPerSe. Utilities setAuthorInitials: 'programmatic'. self compile: code classified: cat. Utilities setAuthorInitials: oldInitials. "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 1/28/2004 14:47'! compileUnlogged: text classified: category notifying: requestor self deprecated: 'Use compileSilently:classified:notifying: instead.'. ^ self compileSilently: text classified: category notifying: requestor. " | selector | self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^ nil] elseSetSelectorAndNode: [:sel :node | selector _ sel]. self organization classify: selector under: category. ^ selector "! ! !ClassDescription methodsFor: 'deprecated' stamp: 'sd 2/1/2004 18:01'! letUserReclassify: anElement "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" self deprecated: 'Use CodeHolder>>letUserReclassify: anElement in: aClass'. CodeHolder new letUserReclassify: anElement in: self.! ! !ClassDescription methodsFor: 'deprecated' stamp: 'NS 4/7/2004 13:33'! removeSelectorUnlogged: aSymbol "Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise. Do not log the action either to the current change set or to the changes log" self deprecated: 'Use removeSelectorSilently: instead'. (self methodDict includesKey: aSymbol) ifFalse: [^ nil]. SystemChangeNotifier uniqueInstance doSilently: [ self organization removeElement: aSymbol]. super removeSelector: aSymbol.! ! !ClassDescription methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:45'! allUnreferencedClassVariables "Answer a list of the names of all the receiver's unreferenced class vars, including those defined in superclasses" ^ self systemNavigation allUnreferencedClassVariablesOf: self! ! !ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'! setUp "I am the method in which your test is initialized. If you have ressources to build, put them here."! ! !ClassDescriptionTest methodsFor: 'initialize-release' stamp: 'md 3/26/2003 17:34'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !ClassDescriptionTest methodsFor: 'testing' stamp: 'md 3/26/2003 17:37'! testOrganization | aClassOrganizer | aClassOrganizer := ClassDescription organization. self should: [aClassOrganizer isKindOf: ClassOrganizer].! ! !ClassDescriptionTest commentStamp: '' prior: 0! This is the unit test for the class ClassDescription. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ClassDiffBuilder methodsFor: 'printing' stamp: 'nk 4/24/2004 08:49'! printPatchSequence: ps on: aStream | type line | ps do: [:assoc | type := assoc key. line := assoc value. aStream withAttributes: (self attributesOf: type) do: [aStream nextPutAll: line]]! ! !ClassListBrowser methodsFor: 'initialization' stamp: 'sw 7/18/2002 22:43'! initForClassesNamed: nameList title: aTitle "Initialize the receiver for the class-name-list and title provided" self systemOrganizer: SystemOrganization. metaClassIndicated _ false. defaultTitle _ aTitle. classList _ nameList copy. self class openBrowserView: (self openSystemCatEditString: nil) label: aTitle "ClassListBrowser new initForClassesNamed: #(Browser CategoryViewer) title: 'Frogs'"! ! !ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:42'! defaultTitle: aTitle "Set the browser's default title" defaultTitle _ aTitle! ! !ClassListBrowser methodsFor: 'title' stamp: 'sw 7/18/2002 22:43'! labelString "Answer the label strilng to use on the browser" ^ defaultTitle ifNil: [super labelString]! ! !ClassListBrowser commentStamp: '' prior: 0! A ClassListBrowser displays the code for an arbitrary list of classes. ClassListBrowser example1. "all classes that have the string 'Pluggable' in their names" ClassListBrowser example2. "all classes whose names start with the letter S" ClassListBrowser example3. "all variable classes" ClassListBrowser example4. "all classes with more than 100 methods" ClassListBrowser example5. "all classes that lack class comments" ClassListBrowser example6. "all classes that have class instance variables" ClassListBrowser new initForClassesNamed: #(Browser Boolean) title: 'Browser and Boolean!!'. ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:01'! example1 "Put up a ClassListBrowser that shows all classes that have the string 'Pluggable' in their names" self browseClassesSatisfying: [:cl | cl name includesSubString: 'Pluggable'] title: 'Pluggables' "ClassListBrowser example1" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sd 4/17/2003 21:21'! example2 "Put up a ClassListBrowser that shows all classes whose names start with the letter S" self new initForClassesNamed: (self systemNavigation allClasses collect: [:c | c name] thenSelect: [:aName | aName first == $S]) title: 'All classes starting with S' "ClassListBrowser example2"! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:03'! example3 "Put up a ClassListBrowser that shows all Variable classes" self browseClassesSatisfying: [:c | c isVariable] title: 'All Variable classes' "ClassListBrowser example3" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 16:04'! example4 "Put up a ClassListBrowser that shows all classes implementing more than 100 methods" self browseClassesSatisfying: [:c | (c selectors size + c class selectors size) > 100] title: 'Classes with more than 100 methods' "ClassListBrowser example4" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:32'! example5 "Put up a ClassListBrowser that shows all classes that lack class comments" self browseClassesSatisfying: [:c | c organization classComment isEmptyOrNil] title: 'Classes lacking class comments' "ClassListBrowser example5" ! ! !ClassListBrowser class methodsFor: 'examples' stamp: 'sw 7/27/2002 14:33'! example6 "Put up a ClassListBrowser that shows all classes that have class instance variables" self browseClassesSatisfying: [:c | c class instVarNames size > 0] title: 'Classes that define class-side instance variables' "ClassListBrowser example6"! ! !ClassListBrowser class methodsFor: 'instance creation' stamp: 'sd 4/17/2003 21:21'! browseClassesSatisfying: classBlock title: aTitle "Put up a ClassListBrowser showing all classes that satisfy the classBlock." self new initForClassesNamed: (self systemNavigation allClasses select: [:c | (classBlock value: c) == true] thenCollect: [:c | c name]) title: aTitle! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 10:15'! notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 23:02'! notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) ifTrue: [SystemChangeNotifier uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 22:52'! notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ SystemChangeNotifier uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self subject ].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/12/2004 20:56'! notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil | newCat | (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | newCat _ newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! addCategory: catString before: nextCategory | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super addCategory: catString before: nextCategory]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/15/2004 12:28'! changeFromCategorySpecs: categorySpecs | oldDict oldCategories | oldDict _ self elementCategoryDict. oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super changeFromCategorySpecs: categorySpecs]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! classify: element under: heading suppressIfDefault: aBoolean | oldCat newCat | oldCat _ self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super classify: element under: heading suppressIfDefault: aBoolean]. newCat _ self categoryOfElement: element. self notifyOfChangedSelector: element from: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! removeCategory: cat | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeCategory: cat]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:37'! removeElement: element | oldCat | oldCat _ self categoryOfElement: element. SystemChangeNotifier uniqueInstance doSilently: [ super removeElement: element]. self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! removeEmptyCategories | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super removeEmptyCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! renameCategory: oldCatString toBe: newCatString | oldCat newCat oldElementsBefore oldElementsAfter | oldCat _ oldCatString asSymbol. newCat _ newCatString asSymbol. oldElementsBefore _ self listAtCategoryNamed: oldCat. SystemChangeNotifier uniqueInstance doSilently: [ super renameCategory: oldCatString toBe: newCatString]. oldElementsAfter _ (self listAtCategoryNamed: oldCat) asSet. oldElementsBefore do: [:each | (oldElementsAfter includes: each) ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat]. ]. self notifyOfChangedCategoryFrom: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/12/2004 20:57'! setDefaultList: aSortedCollection | oldDict oldCategories | oldDict _ self elementCategoryDict. oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super setDefaultList: aSortedCollection]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:38'! sortCategories | oldCategories | oldCategories _ self categories copy. SystemChangeNotifier uniqueInstance doSilently: [ super sortCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0! I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! !ClassRenameFixTest methodsFor: 'Private' stamp: 'rw 8/23/2003 16:04'! newUniqueClassName "Return a class name that is not used in the system." "self new newClassName" | baseName newName | baseName := 'AutoGeneratedClassForTestingSystemChanges'. 1 to: 9999 do: [:number | newName := baseName , number printString. (Smalltalk hasClassNamed: newName) ifFalse: [^newName asSymbol]]. ^self error: 'Can no longer find a new and unique class name for the SystemChangeTest !!'! ! !ClassRenameFixTest methodsFor: 'Private' stamp: 'rw 8/23/2003 16:17'! removeEverythingInSetFromSystem: aChangeSet aChangeSet changedMessageList do: [:methodRef | methodRef actualClass removeSelector: methodRef methodSymbol]. aChangeSet changedClasses do: [:each | each isMeta ifFalse: [each removeFromSystemUnlogged]]! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:46'! renameClassUsing: aBlock | originalName createdClass newClassName foundClasses | originalName := self newUniqueClassName. createdClass := Object subclass: originalName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ClassRenameFix-GeneradClass'. newClassName := self newUniqueClassName. aBlock value: createdClass value: newClassName. self assert: (Smalltalk classNamed: originalName) isNil. self assert: (Smalltalk classNamed: newClassName) notNil. foundClasses := Smalltalk organization listAtCategoryNamed: 'ClassRenameFix-GeneradClass'. self assert: (foundClasses notEmpty). self assert: (foundClasses includes: newClassName). self assert: (createdClass name = newClassName).! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:45'! testRenameClassUsingClass "self run: #testRenameClassUsingClass" self renameClassUsing: [:class :newName | class rename: newName].! ! !ClassRenameFixTest methodsFor: 'Tests' stamp: 'rw 8/23/2003 16:45'! testRenameClassUsingSystemDictionary "self run: #testRenameClassUsingSystemDictionary" self renameClassUsing: [:class :newName | Smalltalk renameClass: class as: newName].! ! !ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:16'! setUp previousChangeSet := ChangeSet current. testsChangeSet := ChangeSet new. ChangeSet newChanges: testsChangeSet. super setUp! ! !ClassRenameFixTest methodsFor: 'Running' stamp: 'rw 8/23/2003 16:17'! tearDown self removeEverythingInSetFromSystem: testsChangeSet. ChangeSet newChanges: previousChangeSet. ChangeSorter removeChangeSet: testsChangeSet. previousChangeSet := nil. testsChangeSet := nil. super tearDown.! ! !ClassTest methodsFor: 'setup' stamp: 'md 1/5/2004 14:59'! setUp Smalltalk removeClassNamed: #TUTU. Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Kernel-Classes'! ! !ClassTest methodsFor: 'setup' stamp: 'sd 12/28/2003 10:53'! tearDown Smalltalk removeClassNamed: #TUTU. ! ! !ClassTest methodsFor: 'testing' stamp: 'md 1/5/2004 14:59'! testAddInstVarName "self run: #testAddInstVarName" | tutu | tutu := Smalltalk at: #TUTU. tutu addInstVarName: 'x'. self assert: (tutu instVarNames = #('x')). tutu addInstVarName: 'y'. self assert: (tutu instVarNames = #('x' 'y')) ! ! !ClassTest methodsFor: 'testing - compiling' stamp: 'md 4/16/2003 14:54'! testCompileAll self shouldnt: [ClassTest compileAll] raise: Error.! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'! categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:28'! targetClass |className| className := self class name asText copyFrom: 0 to: self class name size - 4. ^ Smalltalk at: (className asString asSymbol). ! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:39'! testClassComment self shouldnt: [self targetClass organization hasNoComment].! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/25/2003 23:07'! testNew self shouldnt: [self targetClass new] raise: Error.! ! !ClassTestCase methodsFor: 'testing' stamp: 'md 3/26/2003 17:24'! testUnCategorizedMethods | categories slips | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. self should: [slips isEmpty]. ! ! !ClassTestCase methodsFor: 'Tests' stamp: 'brp 12/14/2003 15:51'! testCoverage | untested | self class mustTestCoverage ifTrue: [ untested := self selectorsNotTested. self assert: untested isEmpty description: untested size asString, ' selectors are not covered' ]! ! !ClassTestCase methodsFor: 'Private' stamp: 'rhi 5/27/2004 14:04'! resumeFromDeprecatedMethods: autoResume "If true, make the default action for all Deprecation warnings to resume" | da | autoResume ifTrue: [Deprecation compiledMethodAt: #defaultAction ifAbsent: [ Deprecation addSelector: #defaultAction withMethod: (Notification >> #defaultAction) ] ] ifFalse: [da _ Deprecation compiledMethodAt: #defaultAction ifAbsent: []. da == (Notification >> #defaultAction) ifTrue: [ Deprecation basicRemoveSelector: #defaultAction] ]! ! !ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:25'! setUp self resumeFromDeprecatedMethods: true.! ! !ClassTestCase methodsFor: 'Running' stamp: 'brp 8/6/2003 19:26'! tearDown self resumeFromDeprecatedMethods: false.! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:39'! classToBeTested self subclassResponsibility! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 16:35'! selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 17:36'! selectorsTested | literals | literals _ Set new. self class selectorsAndMethodsDo: [ :s :m | (s beginsWith: 'test') ifTrue: [ literals addAll: (m literals select: [ :l | l isSymbol and: [l first isLowercase]]) ] ]. ^ literals! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/26/2003 17:22'! selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ! !ClassTestCase methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:40'! selectorsToBeTested ^ ( { self classToBeTested. self classToBeTested class } gather: [:c | c selectors]) difference: self selectorsToBeIgnored! ! !ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0! This class is intended for unit tests of individual classes and their metaclasses. It provides methods to determine the coverage of the unit tests. Subclasses are expected to re-implement #classesToBeTested and #selectorsToBeIgnored. They should also implement to confirm that all methods have been tested. #testCoverage super testCoverage. ! !ClassTestCase class methodsFor: 'Testing' stamp: 'brp 7/27/2003 12:53'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #ClassTestCase ! ! !ClassTestCase class methodsFor: 'Testing' stamp: 'brp 12/14/2003 15:50'! mustTestCoverage ^ false! ! !CleanKernelTest methodsFor: 'utility'! classesCreated classesCreated ifNil: [ classesCreated := OrderedCollection new]. ^ classesCreated! ! !CleanKernelTest methodsFor: 'utility'! createClassNamed: aClassname ^ self createClassNamed: aClassname superClass: Object! ! !CleanKernelTest methodsFor: 'utility' stamp: 'rw 5/12/2003 12:33'! createClassNamed: aClassname superClass: aClass ^self createClassNamed: aClassname superClass: aClass instanceVariables: ''! ! !CleanKernelTest methodsFor: 'utility' stamp: 'md 10/30/2003 09:49'! createClassNamed: aClassname superClass: aClass instanceVariables: instvarString | r | r := aClass subclass: aClassname instanceVariableNames: instvarString classVariableNames: '' poolDictionaries: '' category: 'Tests-KCP'. self classesCreated add: r. ^ r! ! !CleanKernelTest methodsFor: 'utility' stamp: 'md 10/29/2003 23:45'! isSelector: aSymbol definedInClass: aClassSymbol | cls | cls := Smalltalk at: aClassSymbol ifAbsent: [^ false]. ^ cls selectors includes: aSymbol! ! !CleanKernelTest methodsFor: 'utility' stamp: 'sd 4/29/2003 21:43'! isSelector: aSymbol definedInClassOrMetaClass: aClass ^ (aClass selectors includes: aSymbol)! ! !CleanKernelTest methodsFor: 'utility' stamp: 'md 7/16/2004 16:46'! isSelector: aSymbol deprecatedInClass: aClassSymbol | cls | cls _ Smalltalk at: aClassSymbol ifAbsent: [^ false]. ^ (cls >> aSymbol) literals includesAllOf: #(deprecated:)! ! !CleanKernelTest methodsFor: 'utility'! removeClassNamedIfExists: aClassname Smalltalk at: aClassname ifPresent: [:cls| cls removeFromSystem]. Smalltalk at: aClassname ifPresent: [:clss| self error: 'Error !!!!']! ! !CleanKernelTest methodsFor: 'Running' stamp: 'rw 5/12/2003 12:52'! setUp | classBuilderTestClass classBuilderTestSubClass | self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var1 var2'. classBuilderTestClass := (Smalltalk at: #ClassBuilderTestClass). classBuilderTestClass compile: 'var1 ^var1'. classBuilderTestClass compile: 'var1: object var1 := object'. classBuilderTestClass compile: 'var2 ^var2'. classBuilderTestClass compile: 'var2: object var2 := object'. self createClassNamed: #ClassBuilderTestSubClass superClass: classBuilderTestClass instanceVariables: 'var3 var4'. classBuilderTestSubClass := (Smalltalk at: #ClassBuilderTestSubClass). classBuilderTestSubClass compile: 'var3 ^var3'. classBuilderTestSubClass compile: 'var3: object var3 := object'. classBuilderTestSubClass compile: 'var4 ^var4'. classBuilderTestSubClass compile: 'var4: object var4 := object'.! ! !CleanKernelTest methodsFor: 'Running' stamp: 'sd 5/23/2003 14:52'! tearDown | name | self classesCreated do: [:cls | name _ cls name. self removeClassNamedIfExists: name. ChangeSet current removeClassChanges: name]. classesCreated _ nil! ! !CleanKernelTest methodsFor: 'behavior'! testAccessingClassHierarchy "self run: #testAccessingClassHierarchy" | clsRoot clsA clsB clsC1 clsC2 | clsRoot _ self createClassNamed: #Root. clsA _ self createClassNamed: #A superClass: clsRoot. clsB _ self createClassNamed: #B superClass: clsA. clsC1 _ self createClassNamed: #C1 superClass: clsB. clsC2 _ self createClassNamed: #C2 superClass: clsB. "--------" self assert: clsRoot subclasses size = 1. self assert: (clsRoot subclasses includes: clsA). self assert: clsB subclasses size = 2. self assert: (clsB subclasses includesAllOf: (Array with: clsC1 with: clsC2)). self assert: clsC1 subclasses isEmpty. "--------" self assert: clsRoot allSubclasses size = 4. self assert: (clsRoot allSubclasses includesAllOf: (Array with: clsA with: clsB with: clsC1 with: clsC2)). "--------" self assert: clsRoot withAllSubclasses size = 5. self assert: (clsRoot withAllSubclasses includesAllOf: (Array with: clsA with: clsB with: clsC1 with: clsC2 with: clsRoot)). ! ! !CleanKernelTest methodsFor: 'behavior'! testAccessingClassHierarchySuperclasses "self run: #testAccessingClassHierarchySuperclasses" | clsRoot clsA clsB clsC1 clsC2 | clsRoot _ self createClassNamed: #Root. clsA _ self createClassNamed: #A superClass: clsRoot. clsB _ self createClassNamed: #B superClass: clsA. clsC1 _ self createClassNamed: #C1 superClass: clsB. clsC2 _ self createClassNamed: #C2 superClass: clsB. "--------" self assert: clsC2 superclass == clsB. self assert: (clsC2 allSuperclasses includes: clsA). self assert: clsC2 allSuperclasses size = 5. self assert: (clsC2 allSuperclasses includesAllOf: (Array with: clsB with: clsA with: clsRoot with: Object with: ProtoObject)). "--------" self assert: clsC1 superclass == clsB. self assert: (clsC1 allSuperclasses includes: clsA). self assert: clsC1 allSuperclasses size = 5. self assert: (clsC1 allSuperclasses includesAllOf: (Array with: clsB with: clsA with: clsRoot with: Object with: ProtoObject)). "--------" self assert: clsC2 withAllSuperclasses size = (clsC2 allSuperclasses size + 1). self assert: (clsC2 withAllSuperclasses includesAllOf: clsC2 allSuperclasses). self assert: (clsC2 withAllSuperclasses includes: clsC2). "--------" self assert: clsC1 withAllSuperclasses size = (clsC1 allSuperclasses size + 1). self assert: (clsC1 withAllSuperclasses includesAllOf: clsC1 allSuperclasses). self assert: (clsC1 withAllSuperclasses includes: clsC1)! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:15'! testAllCallsOn "self run: #testAllCallsOn" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol) size = 7. self assert: (SystemNavigation new allCallsOn: #callingAnotherMethod) size = 2! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 13:17'! testAllCallsOnAnd "self run: #testAllCallsOnAnd" self class forgetDoIts. self assert: (SystemNavigation new allCallsOn: #zoulouSymbol and: #callingAThirdMethod) size = 2. self assert: (SystemNavigation new allCallsOn: #callingAThirdMethod and: #inform:) size = 1! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/29/2003 20:43'! testAllMethodsSelect "self run: #testAllMethodsSelect" | res | res _ SystemNavigation new allMethodsSelect: [:each | each messages includes: #zoulouSymbol]. self assert: res size = 1. self assert: (res at: 1) methodSymbol = #callingAThirdMethod! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:44'! testIsThereAnImplementorOf "self run: #testIsThereAnImplementorOf" self deny: (SystemNavigation new isThereAnImplementorOf: #nobodyImplementsThis) . self assert: (SystemNavigation new isThereAnImplementorOf: #zoulouSymbol).! ! !CleanKernelTest methodsFor: 'query' stamp: 'sd 4/18/2003 10:41'! testNumberOfImplementors "self run: #testNumberOfImplementors" self assert: (SystemNavigation new numberOfImplementorsOf: #nobodyImplementsThis) isZero. self assert: (SystemNavigation new numberOfImplementorsOf: #zoulouSymbol) = 2.! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testBehaviorDefineIsMeta self deny: Behavior new isMeta! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testMetaclassDefineIsMeta self assert: Metaclass new isMeta! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:37'! testMovePowerManagementToPwerManagement self assert: (self isSelector: #disablePowerManager definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #enablePowerManager definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #disablePowerManager: definedInClassOrMetaClass: PowerManagement class). self assert: (self isSelector: #itsyVoltage definedInClassOrMetaClass: PowerManagement class)! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:45'! testMoveSortAllCategoriesToClassOrganizer self assert: (self isSelector: #sortAllCategories definedInClassOrMetaClass: ClassOrganizer class). ! ! !CleanKernelTest methodsFor: 'isMeta' stamp: 'md 10/30/2003 09:29'! testPullUpIsMeta self deny: (self isSelector: #isMeta definedInClass: #ClassDescription). self deny: (self isSelector: #isMeta definedInClass: #Class). self assert: (self isSelector: #isMeta definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'isMeta'! testPullUpIsWithAllSubclasses "self run: #testPullUpIsWithAllSubclasses" self deny: (self isSelector: #withAllSubclasses definedInClass: #ClassDescription). self assert: (self isSelector: #withAllSubclasses definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:08'! testMetaclassClassClassDescriptionDoesNotReferToSmalltalk "self run: #testMetaclassClassClassDescriptionDoesNotReferToSmalltalk" self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk). self deny: ((Analyzer externalReferenceOf: (Array with: ClassDescription)) includes: #Smalltalk). self deny: ((Analyzer externalReferenceOf: (Array with: Class)) includes: #Smalltalk).! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 16:06'! testMetaclassDoesNotReferToSmalltalk "self run: #testMetaclassDoesNotReferToSmalltalk" self deny: ((Analyzer externalReferenceOf: (Array with: Metaclass)) includes: #Smalltalk).! ! !CleanKernelTest methodsFor: 'environment' stamp: 'sd 3/28/2003 15:16'! testNilEnvironment "self run: #testNilEnvironment" self assert: nil environment == Smalltalk! ! !CleanKernelTest methodsFor: 'allSubclasses' stamp: 'md 10/30/2003 09:30'! testPullUpAllSubclasses self deny: (self isSelector: #allSubclasses definedInClass: #ClassDescription). self assert: (self isSelector: #allSubclasses definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'browing' stamp: 'sd 3/28/2003 17:00'! testRemoveBroweMethod self deny: (self isSelector: #browse definedInClass: #Behavior)! ! !CleanKernelTest methodsFor: 'module reference' stamp: 'md 10/29/2003 23:44'! testRemoveSubclassModuleMethod self deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:module: definedInClass: #Class)! ! !CleanKernelTest methodsFor: 'module reference' stamp: 'sd 3/28/2003 18:15'! testRemoveSubclassModuleMethodInClass self deny: (self isSelector: #existingCategoryFor:orConvert: definedInClass: #Class). self deny: (self isSelector: #subclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableByteSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #variableWordSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). self deny: (self isSelector: #weakSubclass:instanceVariableNames:classVariableNames:module: definedInClass: #Class). ! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:48'! testReshapeClass "see if reshaping classes works" "self run: #testReshapeClass" | testInstance testClass testMeta newClass newMeta | testClass _ Smalltalk at: #ClassBuilderTestClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. newClass _ self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'foo var1 bar var2 mumble'. newMeta _ newClass class. "test transparency of mapping" self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: (testInstance instVarAt: 1) isNil. self assert: (testInstance instVarAt: 2) = 42. self assert: (testInstance instVarAt: 3) isNil. self assert: (testInstance instVarAt: 4) = 'hello'. self assert: (testInstance instVarAt: 5) isNil. "test transparency of reshapes" self assert: testInstance class == newClass. self assert: testClass == newClass. self assert: testMeta == newMeta! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:49'! testReshapeClassWithJugglingInstVars "see if reshapes of classes juggle their instVars correctly" | testInstance testClass testMeta newClass newMeta | testClass _ Smalltalk at: #ClassBuilderTestClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. newClass _ self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var2 foo bar mumble var1'. newMeta _ newClass class. "test transparency of mapping" self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: (testInstance instVarAt: 1) = 'hello'. self assert: (testInstance instVarAt: 2) isNil. self assert: (testInstance instVarAt: 3) isNil. self assert: (testInstance instVarAt: 4) isNil. self assert: (testInstance instVarAt: 5) = 42. "test transparency of reshapes" self assert: testInstance class == newClass. self assert: testClass == newClass. self assert: testMeta == newMeta! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'rw 5/12/2003 12:55'! testReshapeSubClass "self run: #testReshapeSubClass" "self debug: #testReshapeSubClass" | testInstance testClass testMeta | testClass _ Smalltalk at: #ClassBuilderTestSubClass. testMeta _ testClass class. testInstance _ testClass new. testInstance var1: 42. testInstance var2: 'hello'. testInstance var3: 'foo'. testInstance var4: #bar. self createClassNamed: #ClassBuilderTestClass superClass: Object instanceVariables: 'var1 foo var2 bar mumble '. self assert: testInstance var1 = 42. self assert: testInstance var2 = 'hello'. self assert: testInstance var3 = 'foo'. self assert: testInstance var4 = #bar. self assert: (testInstance instVarAt: 1) = 42. self assert: (testInstance instVarAt: 2) isNil. self assert: (testInstance instVarAt: 3) = 'hello'. self assert: (testInstance instVarAt: 4) isNil. self assert: (testInstance instVarAt: 5) isNil. self assert: (testInstance instVarAt: 6) = 'foo'. self assert: (testInstance instVarAt: 7) = #bar. self assert: testInstance class == (Smalltalk at: #ClassBuilderTestSubClass). self assert: testClass == (Smalltalk at: #ClassBuilderTestSubClass). self assert: testMeta == (Smalltalk at: #ClassBuilderTestSubClass) class! ! !CleanKernelTest methodsFor: 'classBuilder' stamp: 'sd 5/23/2003 14:52'! testValidateSubclassFormatFix "Recompiling Array" self shouldnt: [ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'] raise: Error. ChangeSet current removeClassChanges: #Array! ! !CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:09'! testTheMetaClass "self run: #testTheMetaClass" self assert: Class class theMetaClass == Class class. self assert: Class theMetaClass == Class class.! ! !CleanKernelTest methodsFor: 'theNonMetaclass' stamp: 'sd 6/27/2003 23:10'! testTheNonMetaClass "self run: #testTheNonMetaClass" self assert: Class class theNonMetaClass == Class. self assert: Class theNonMetaClass == Class.! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:07'! clearInterpreter interpreter _ nil. ! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:04'! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | string decodedString | string _ self primitiveClipboardText. (string isEmpty or: [string = contents asString]) ifTrue: [^ contents]. decodedString _ self interpreter fromSystemClipboard: string. ^ decodedString = contents asString ifTrue: [contents] ifFalse: [decodedString asText]. ! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 19:12'! clipboardText: text | string | string _ text asString. self noteRecentClipping: text asText. contents _ text asText. string _ self interpreter toSystemClipboard: string. self primitiveClipboardText: string. ! ! !Clipboard methodsFor: 'accessing' stamp: 'yo 8/11/2003 18:23'! interpreter interpreter ifNil: [self setInterpreter]. ^ interpreter. ! ! !Clipboard methodsFor: 'accessing' stamp: 'mir 7/20/2004 15:44'! setInterpreter interpreter _ LanguageEnvironment defaultClipboardInterpreter. interpreter ifNil: [ "Should never be reached, but just in case." interpreter _ NoConversionClipboardInterpreter new]. ! ! !Clipboard class methodsFor: 'class initialization' stamp: 'yo 8/11/2003 22:43'! clearInterpreters self allInstances do: [:each | each clearInterpreter]. ! ! !Clipboard class methodsFor: 'class initialization' stamp: 'yo 12/29/2003 01:03'! startUp self clearInterpreters. ! ! !ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'! fromSystemClipboard: aString self subclassResponsibility. ! ! !ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'! toSystemClipboard: aString self subclassResponsibility. ! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:33'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 1.0 g: 0.355 b: 0.452! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 6! ! !ClipboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !ClipboardMorph methodsFor: 'parts bin' stamp: 'dgd 2/14/2003 22:09'! initializeToStandAlone super initializeToStandAlone. "" self initialize. "" self extent: 200 @ 100. self backgroundColor: (Color r: 0.484 g: 1.0 b: 0.484). self setBalloonText: 'This shows the current contents of the text clipboard'. self newContents: Clipboard clipboardText! ! !ClipboardMorph methodsFor: 'stepping and presenter' stamp: 'sw 6/27/2001 14:15'! step self newContents: Clipboard clipboardText! ! !ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 14:18'! stepTime "Answer the interval between steps -- in this case a leisurely 1 seconds" ^ 1000! ! !ClipboardMorph methodsFor: 'testing' stamp: 'sw 6/27/2001 13:40'! wantsSteps ^ true! ! !ClipboardMorph commentStamp: '' prior: 0! A morph that always displays the current contents of the text clipboard.! !ClipboardMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:21'! descriptionForPartsBin ^ self partName: 'Clipboard' categories: #('Useful') documentation: 'This object will always show whatever is on the text clipboard'! ! !ClockMorph methodsFor: 'initialization' stamp: 'fc 2/8/2004 11:33'! initialize "initialize the state of the receiver" super initialize. "" showSeconds _ true. show24hr _ false. self step! ! !ClockMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 17:41'! initializeToStandAlone super initializeToStandAlone. showSeconds _ true. self step! ! !ClockMorph methodsFor: 'stepping and presenter' stamp: 'fc 2/8/2004 11:40'! step | time | super step. time _ String streamContents: [:aStrm | Time now print24: (show24hr == true) showSeconds: (showSeconds == true) on: aStrm]. self contents: time ! ! !ClockMorph methodsFor: 'menu' stamp: 'fc 2/8/2004 11:57'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Note minor loose end here -- if the menu is persistent, then the wording will be wrong half the time" | item | super addCustomMenuItems: aCustomMenu hand: aHandMorph. item _ showSeconds == true ifTrue: ['stop showing seconds'] ifFalse: ['start showing seconds']. aCustomMenu add: item translated target: self action: #toggleShowingSeconds. item _ show24hr == true ifTrue: ['display Am/Pm'] ifFalse: ['display 24 hour']. aCustomMenu add: item translated target: self action: #toggleShowing24hr. ! ! !ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:38'! show24hr: aBoolean show24hr _ aBoolean! ! !ClockMorph methodsFor: '24hr' stamp: 'fc 2/8/2004 11:39'! toggleShowing24hr show24hr _ (show24hr == true) not ! ! !ClockMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 01:22'! descriptionForPartsBin ^ self partName: 'Clock' categories: #('Useful') documentation: 'A digital clock'! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:00'! initialize self registerInFlapsRegistry. ! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:02'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'Supplies'. cl registerQuad: #(ClockMorph authoringPrototype 'Clock' 'A simple digital clock') forFlapNamed: 'PlugIn Supplies'.]! ! !ClockMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:54'! = other self class == other class ifFalse: [^ false]. self size = other size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (other at: i) ifFalse: [^ false]. ]. ^ true! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/24/2004 03:56'! hash "Answer an integer hash value for the receiver such that, -- the hash value of an unchanged object is constant over time, and -- two equal objects have equal hash values" | hash | hash _ self species hash. self size <= 10 ifTrue: [self do: [:elem | hash _ hash bitXor: elem hash]]. ^hash bitXor: self size hash! ! !ClosureEnvironment methodsFor: 'as yet unclassified' stamp: 'ajh 6/29/2004 14:33'! return: value "Find thisContext sender that is owner of self and return from it" | home | home _ thisContext findContextSuchThat: [:ctxt | ctxt myEnv == self]. home return: value! ! !ClosureEnvironment commentStamp: 'ajh 6/24/2004 03:33' prior: 0! An environment is a collection of temporary variable values that have escaped the original method context and placed in this environment because blocks existed in the method that reference these variables (and blocks may out live their creating context). Nested blocks create nested environments when temp vars are introduced at multiple levels and referenced at lower levels. So each environment has a parent environment in its first slot. The top environment has the original receiver in it first slot (if referenced by an inner block). A block consists of its outer environment and a method to execute while the outer environment is in the receiver position. A block that remote returns from its home context holds the home environment in its outer environment. The remote return unwinds the call stack to the context that created the home context. ! !CodeHolder methodsFor: 'annotation' stamp: 'nk 4/28/2004 10:16'! addOptionalAnnotationsTo: window at: fractions plus: verticalOffset "Add an annotation pane to the window if preferences indicate a desire for it, and return the incoming verticalOffset plus the height of the added pane, if any" | aTextMorph divider delta | self wantsAnnotationPane ifFalse: [^ verticalOffset]. aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: #annotationPaneMenu:shifted:. aTextMorph askBeforeDiscardingEdits: false; borderWidth: 0; hideScrollBarsIndefinitely. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. delta _ self defaultAnnotationPaneHeight. window addMorph: aTextMorph fullFrame: (LayoutFrame fractions: fractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:00'! addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream "add an annotation detailing the prior versions count" | versionsCount | versionsCount _ VersionsBrowser versionCountForSelector: aSelector class: aClass. aStream nextPutAll: ((versionsCount > 1 ifTrue: [versionsCount == 2 ifTrue: ['1 prior version'] ifFalse: [versionsCount printString, ' prior versions']] ifFalse: ['no prior versions']), self annotationSeparator)! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/11/2002 21:30'! annotationForClassCommentFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the clas comment of the given class." | aStamp nonMeta | aStamp _ (nonMeta _ aClass theNonMetaClass) organization commentStamp. ^ aStamp ifNil: [nonMeta name, ' has no class comment'] ifNotNil: ['class comment for ', nonMeta name, (aStamp = '' ifFalse: [' - ', aStamp] ifTrue: [''])]! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForClassDefinitionFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the class definition of the given class." ^ 'Class definition for ', aClass name! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 8/26/2002 10:19'! annotationForHierarchyFor: aClass "Provide a line of content for an annotation pane, given that the receiver is pointing at the hierarchy of the given class." ^ 'Hierarchy for ', aClass name! ! !CodeHolder methodsFor: 'annotation' stamp: 'sd 4/29/2003 11:54'! annotationForSelector: aSelector ofClass: aClass "Provide a line of content for an annotation pane, representing information about the given selector and class" | stamp sendersCount implementorsCount aCategory separator aString aList aComment aStream requestList | aSelector == #Comment ifTrue: [^ self annotationForClassCommentFor: aClass]. aSelector == #Definition ifTrue: [^ self annotationForClassDefinitionFor: aClass]. aSelector == #Hierarchy ifTrue: [^ self annotationForHierarchyFor: aClass]. aStream _ ReadWriteStream on: ''. requestList _ self annotationRequests. separator _ requestList size > 1 ifTrue: [self annotationSeparator] ifFalse: ['']. requestList do: [:aRequest | aRequest == #firstComment ifTrue: [aComment _ aClass firstCommentAt: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #masterComment ifTrue: [aComment _ aClass supermostPrecodeCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #documentation ifTrue: [aComment _ aClass precodeCommentOrInheritedCommentFor: aSelector. aComment isEmptyOrNil ifFalse: [aStream nextPutAll: aComment , separator]]. aRequest == #timeStamp ifTrue: [stamp _ self timeStamp. aStream nextPutAll: (stamp size > 0 ifTrue: [stamp , separator] ifFalse: ['no timeStamp' , separator])]. aRequest == #messageCategory ifTrue: [aCategory _ aClass organization categoryOfElement: aSelector. aCategory ifNotNil: ["woud be nil for a method no longer present, e.g. in a recent-submissions browser" aStream nextPutAll: aCategory , separator]]. aRequest == #sendersCount ifTrue: [sendersCount _ (self systemNavigation allCallsOn: aSelector) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString , ' senders']. aStream nextPutAll: sendersCount , separator]. aRequest == #implementorsCount ifTrue: [implementorsCount _ self systemNavigation numberOfImplementorsOf: aSelector. implementorsCount _ implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString , ' implementors']. aStream nextPutAll: implementorsCount , separator]. aRequest == #priorVersionsCount ifTrue: [self addPriorVersionsCountForSelector: aSelector ofClass: aClass to: aStream]. aRequest == #priorTimeStamp ifTrue: [stamp _ VersionsBrowser timeStampFor: aSelector class: aClass reverseOrdinal: 2. stamp ifNotNil: [aStream nextPutAll: 'prior time stamp: ' , stamp , separator]]. aRequest == #recentChangeSet ifTrue: [aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: aClass selector: aSelector. aString size > 0 ifTrue: [aStream nextPutAll: aString , separator]]. aRequest == #allChangeSets ifTrue: [aList _ ChangeSorter allChangeSetsWithClass: aClass selector: aSelector. aList size > 0 ifTrue: [aList size = 1 ifTrue: [aStream nextPutAll: 'only in change set '] ifFalse: [aStream nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | aStream nextPutAll: aChangeSet name , ' ']] ifFalse: [aStream nextPutAll: 'in no change set']. aStream nextPutAll: separator]]. ^ aStream contents! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:43'! defaultAnnotationPaneHeight "Answer the receiver's preferred default height for new annotation panes." ^ Preferences parameterAt: #defaultAnnotationPaneHeight ifAbsentPut: [25]! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 9/28/2001 08:44'! defaultButtonPaneHeight "Answer the user's preferred default height for new button panes." ^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:56'! categoryFromUserWithPrompt: aPrompt for: aClass "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" | labels myCategories reject lines cats newName menuIndex | labels _ OrderedCollection with: 'new...'. labels addAll: (myCategories _ aClass organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject _ myCategories asSet. reject add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection with: 1 with: (myCategories size + 1). aClass allSuperclasses do: [:cls | cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [lines add: labels size. labels addAll: (cats asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject addAll: cats]]. newName _ (labels size = 1 or: [menuIndex _ (PopUpMenu labelArray: labels lines: lines) startUpWithCaption: aPrompt. menuIndex = 0 ifTrue: [^ nil]. menuIndex = 1]) ifTrue: [FillInTheBlank request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [labels at: menuIndex]. ^ newName ifNotNil: [newName asSymbol]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:55'! categoryOfCurrentMethod "Answer the category that owns the current method. If unable to determine a category, answer nil." | aClass aSelector | ^ (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [aClass whichCategoryIncludesSelector: aSelector]]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:55'! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [(self letUserReclassify: aSelector in: aClass) ifTrue: ["ChangeSet current reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'categories' stamp: 'sd 2/1/2004 17:54'! letUserReclassify: anElement in: aClass "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" | currentCat newCat | currentCat _ aClass organization categoryOfElement: anElement. newCat _ self categoryFromUserWithPrompt: 'choose category (currently "', currentCat, '")' for: aClass. (newCat ~~ nil and: [newCat ~= currentCat]) ifTrue: [aClass organization classify: anElement under: newCat suppressIfDefault: false. ^ true] ifFalse: [^ false]! ! !CodeHolder methodsFor: 'contents' stamp: 'sw 12/11/2000 10:42'! commentContents "documentation for the selected method" | poss aClass aSelector | ^ (poss _ (aClass _ self selectedClassOrMetaClass) ifNil: ['----'] ifNotNil: [(aSelector _ self selectedMessageName) ifNil: ['---'] ifNotNil: [(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp" "which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]]) isEmptyOrNil ifTrue: [aSelector ifNotNil: [((aClass methodHeaderFor: aSelector), ' Has no comment') asText makeSelectorBoldIn: aClass] ifNil: ['Hamna']] ifFalse: [aSelector ifNotNil: [((aClass methodHeaderFor: aSelector), ' ', poss) asText makeSelectorBoldIn: aClass] ifNil: [poss]]! ! !CodeHolder methodsFor: 'contents' stamp: 'di 10/1/2001 22:25'! contents "Answer the source code or documentation for the selected method" self showingByteCodes ifTrue: [^ self selectedBytecodes]. self showingDocumentation ifTrue: [^ self commentContents]. ^ self selectedMessage! ! !CodeHolder methodsFor: 'contents' stamp: 'rhi 12/3/2001 22:25'! contentsChanged super contentsChanged. self changed: #annotation! ! !CodeHolder methodsFor: 'contents' stamp: 'sw 5/20/2001 10:21'! contentsSymbol "Answer a symbol indicating what kind of content should be shown for the method; for normal showing of source code, this symbol is #source. A nil value in the contentsSymbol slot will be set to #source by this method" ^ contentsSymbol ifNil: [contentsSymbol _ Preferences printAlternateSyntax ifTrue: [#altSyntax] ifFalse: [Preferences browseWithPrettyPrint ifTrue: [Preferences colorWhenPrettyPrinting ifTrue: [#colorPrint] ifFalse: [#prettyPrint]] ifFalse: [#source]]]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 7/30/2001 16:31'! abbreviatedWordingFor: aButtonSelector "Answer the abbreviated form of wording, from a static table which you're welcome to edit. Answer nil if there is no entry -- in which case the long firm will be used on the corresponding browser button." #( (browseMethodFull 'browse') (browseSendersOfMessages 'senders') (browseMessages 'impl') (browseVersions 'vers') (methodHierarchy 'inher') (classHierarchy 'hier') (browseInstVarRefs 'iVar') (browseClassVarRefs 'cVar') (offerMenu 'menu')) do: [:pair | pair first == aButtonSelector ifTrue: [^ pair second]]. ^ nil! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 5/23/2003 14:35'! adoptMessageInCurrentChangeset "Add the receiver's method to the current change set if not already there" self setClassAndSelectorIn: [:cl :sel | cl ifNotNil: [ChangeSet current adoptSelector: sel forClass: cl. self changed: #annotation]] ! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 4/16/2003 09:33'! browseImplementors "Create and schedule a message set browser on all implementors of the currently selected message selector. Do nothing if no message is selected." | aMessageName | (aMessageName _ self selectedMessageName) ifNotNil: [self systemNavigation browseAllImplementorsOf: aMessageName]! ! !CodeHolder methodsFor: 'commands' stamp: 'nk 6/26/2003 21:43'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Of there is no message currently selected, offer a type-in" self sendQuery: #browseAllCallsOn: to: self systemNavigation! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 1/16/2004 21:05'! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu aColor | Smalltalk isMorphic ifFalse: [^ self inform: 'Sorry, for the moment you have to be in Morphic to use this feature.']. ((aClass _ self selectedClassOrMetaClass) isNil or: [(aSelector _ self selectedMessageName) == nil]) ifTrue: [^ Beeper beep]. allClasses _ self systemNavigation hierarchyOfClassesSurrounding: aClass. implementors _ self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu _ MenuMorph new defaultTarget: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | aColor _ cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 5/18/2001 17:51'! offerMenu "Offer a menu to the user from the bar of tool buttons" self offerDurableMenuFrom: #messageListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:14'! offerShiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/27/2001 12:15'! offerUnshiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'commands' stamp: 'nb 6/17/2003 12:25'! removeClass "Remove the selected class from the system, at interactive user request. Make certain the user really wants to do this, since it is not reversible. Answer true if removal actually happened." | message className classToRemove result | self okToChange ifFalse: [^ false]. classToRemove _ self selectedClassOrMetaClass ifNil: [Beeper beep. ^ false]. classToRemove _ classToRemove theNonMetaClass. className _ classToRemove name. message _ 'Are you certain that you want to REMOVE the class ', className, ' from the system?'. (result _ self confirm: message) ifTrue: [classToRemove subclasses size > 0 ifTrue: [(self confirm: 'class has subclasses: ' , message) ifFalse: [^ false]]. classToRemove removeFromSystem. self changed: #classList. true]. ^ result! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:18'! shiftedYellowButtonActivity "Offer the shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 4/29/2003 13:09'! showUnreferencedClassVars "Search for all class variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each class variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClass) ifNil: [^ self]. aList _ self systemNavigation allUnreferencedClassVariablesOf: cls. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced class variables in ' , cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced class variable(s) in ' , cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced class variables in ' , cls name! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 9/26/2001 01:55'! showUnreferencedInstVars "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClassOrMetaClass) ifNil: [^ self]. aList _ cls allUnreferencedInstanceVariables. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced instance variables in ', cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced instance variables in ', cls name! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 2/22/2001 06:38'! spawn: aString "Create and schedule a spawned message category browser for the currently selected message category. The initial text view contains the characters in aString. In the spawned browser, preselect the current selector (if any) as the going-in assumption, though upon acceptance this will often change" | newBrowser aCategory aClass | (aClass _ self selectedClassOrMetaClass) isNil ifTrue: [^ aString isEmptyOrNil ifFalse: [(Workspace new contents: aString) openLabel: 'spawned workspace']]. (aCategory _ self categoryOfCurrentMethod) ifNil: [self buildClassBrowserEditString: aString] ifNotNil: [newBrowser _ Browser new setClass: aClass selector: self selectedMessageName. self suggestCategoryToSpawnedBrowser: newBrowser. Browser openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'category "', aCategory, '" in ', newBrowser selectedClassOrMetaClassName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 11/12/2002 13:41'! spawnHierarchy "Create and schedule a new hierarchy browser on the currently selected class or meta." | newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass | (selectedClassOrMetaClass _ self selectedClassOrMetaClass) ifNil: [^ self]. newBrowser _ HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass. ((aSymbol _ self selectedMessageName) notNil and: [(MessageSet isPseudoSelector: aSymbol) not]) ifTrue: [aBehavior _ selectedClassOrMetaClass. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. newBrowser messageCategoryListIndex: messageCatIndex + 1. newBrowser messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)]. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: newBrowser labelString. Smalltalk isMorphic ifTrue: ["this workaround only needed in morphic" newBrowser assureSelectionsShow]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:10'! spawnToClass: aClass "Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool." | aCategory newBrowser org | (aCategory _ self categoryOfCurrentMethod) ifNil: [self buildClassBrowserEditString: self contents] ifNotNil: [((org _ aClass organization) categories includes: aCategory) ifFalse: [org addCategory: aCategory]. newBrowser _ Browser new setClass: aClass selector: nil. newBrowser selectMessageCategoryNamed: aCategory. Browser openBrowserView: (newBrowser openMessageCatEditString: self contents) label: 'category "', aCategory, '" in ', newBrowser selectedClassOrMetaClassName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:11'! spawnToCollidingClass: aClass "Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted." self inform: 'That would be destructive of some pre-existing code already in that class for this selector. For the moment, we will not let you do this to yourself.'! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/6/2001 15:19'! unshiftedYellowButtonActivity "Offer the unshifted shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'construction' stamp: 'tween 8/27/2004 12:18'! buildMorphicCodePaneWith: editString "Construct the pane that shows the code. Respect the Preference for standardCodeFont." | codePane | codePane := MorphicTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codePane font: Preferences standardCodeFont. editString ifNotNil: [codePane editString: editString. codePane hasUnacceptedEdits: true]. ^ codePane! ! !CodeHolder methodsFor: 'controls' stamp: 'ar 8/19/2001 16:15'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "If the receiver wishes it, add a button pane to the window, and answer the verticalOffset plus the height added" | delta buttons divider | self wantsOptionalButtons ifFalse: [^verticalOffset]. delta _ self defaultButtonPaneHeight. buttons _ self optionalButtonRow color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); borderWidth: 0. Preferences alternativeWindowLook ifTrue:[ buttons color: Color transparent. buttons submorphsDo:[:m| m borderWidth: 2; borderColor: #raised]. ]. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. window addMorph: buttons fullFrame: (LayoutFrame fractions: fractions offsets: (0@verticalOffset corner: 0@(verticalOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(verticalOffset + delta - 1) corner: 0@(verticalOffset + delta))). ^ verticalOffset + delta! ! !CodeHolder methodsFor: 'controls' stamp: 'gm 2/16/2003 20:37'! buttonWithSelector: aSelector "If receiver has a control button with the given action selector answer it, else answer nil. morphic only at this point" | aWindow aPane | ((aWindow := self containingWindow) isSystemWindow) ifFalse: [^nil]. (aPane := aWindow submorphNamed: 'buttonPane') ifNil: [^nil]. ^aPane submorphThat: [:m | (m isKindOf: PluggableButtonMorph) and: [m actionSelector == aSelector]] ifNone: [^nil]! ! !CodeHolder methodsFor: 'controls' stamp: 'ar 8/19/2001 16:28'! codePaneProvenanceButton "Answer a button that reports on, and allow the user to modify, the code-pane-provenance setting" | aButton | aButton _ UpdatingSimpleButtonMorph newWithLabel: 'source'. aButton setNameTo: 'codeProvenance'. aButton useSquareCorners. aButton target: self; wordingSelector: #codePaneProvenanceString; actionSelector: #offerWhatToShowMenu. aButton setBalloonText: 'Governs what view is shown in the code pane. Click here to change the view'. aButton actWhen: #buttonDown. aButton beTransparent. aButton borderColor: Color black. ^aButton! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 5/19/2001 01:12'! codePaneProvenanceString "Answer a string that reports on code-pane-provenance" | symsAndWordings | (symsAndWordings _ self contentsSymbolQuints) do: [:aQuad | contentsSymbol == aQuad first ifTrue: [^ aQuad fourth]]. ^ symsAndWordings first fourth "default to plain source, for example if nil as initially"! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 07:48'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane first element: the contentsSymbol used second element: the selector to call when this item is chosen. third element: the selector to call to obtain the wording of the menu item. fourth element: the wording to represent this view fifth element: balloon help A hypen indicates a need for a seperator line in a menu of such choices" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (documentation toggleShowDocumentation showingDocumentationString 'documentation' 'the first comment in the method') - (prettyPrint togglePrettyPrint prettyPrintString 'prettyPrint' 'the method source presented in a standard text format') (colorPrint toggleColorPrint colorPrintString 'colorPrint' 'the method source in a standard text format with colors to distinguish structural parts') (altSyntax toggleAltSyntax showingAltSyntaxString 'altSyntax' 'alternative syntax') - (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version') - (decompile toggleDecompile showingDecompileString 'decompile' 'source code decompiled from byteCodes') (byteCodes toggleShowingByteCodes showingByteCodesString 'byteCodes' 'the bytecodes that comprise the compiled method') - (tiles toggleShowingTiles showingTilesString 'tiles' 'universal tiles representing the method'))! ! !CodeHolder methodsFor: 'controls' stamp: 'nk 7/6/2003 08:29'! decorateForInheritance "Check to see if the currently-viewed method has a super send or an override, and if so, change screen feedback, unless the #decorateBrowserButtons says not to." | aColor aButton flags | (aButton _ self inheritanceButton) ifNil: [^ self]. ((currentCompiledMethod isKindOf: CompiledMethod) and: [Preferences decorateBrowserButtons]) ifFalse: [^aButton offColor: Color transparent]. "This table duplicates the old logic, but adds two new colors for the cases where there is a superclass definition, but this method doesn't call it." flags _ 0. self isThisAnOverride ifTrue: [ flags _ flags bitOr: 4 ]. currentCompiledMethod sendsToSuper ifTrue: [ flags _ flags bitOr: 2 ]. self isThereAnOverride ifTrue: [ flags _ flags bitOr: 1 ]. aColor _ { Color transparent. Color tan lighter. Color green muchLighter. Color blue muchLighter. Color red muchLighter. "has super but doesn't call it" (Color r: 0.94 g: 0.823 b: 0.673). "has sub; has super but doesn't call it" Color green muchLighter. Color blue muchLighter. } at: flags + 1. aButton offColor: aColor! ! !CodeHolder methodsFor: 'controls' stamp: 'nk 7/7/2003 11:39'! optionalButtonPairs "Answer a tuple (formerly pairs) defining buttons, in the format: button label selector to send help message" | aList | aList _ #( ('browse' browseMethodFull 'view this method in a browser') ('senders' browseSendersOfMessages 'browse senders of...') ('implementors' browseMessages 'browse implementors of...') ('versions' browseVersions 'browse versions')), (Preferences decorateBrowserButtons ifTrue: [{#('inheritance' methodHierarchy 'browse method inheritance green: sends to super tan: has override(s) mauve: both of the above pink: is an override but doesn''t call super pinkish tan: has override(s), also is an override but doesn''t call super' )}] ifFalse: [{#('inheritance' methodHierarchy 'browse method inheritance')}]), #( ('hierarchy' classHierarchy 'browse class hierarchy') ('inst vars' browseInstVarRefs 'inst var refs...') ('class vars' browseClassVarRefs 'class var refs...')). ^ aList! ! !CodeHolder methodsFor: 'controls' stamp: 'tk 9/8/2001 22:40'! optionalButtonRow "Answer a row of control buttons" | aRow aButton aLabel | aRow _ AlignmentMorph newRow. aRow setNameTo: 'buttonPane'. aRow beSticky. aRow hResizing: #spaceFill. aRow wrapCentering: #center; cellPositioning: #leftCenter. aRow clipSubmorphs: true. aRow cellInset: 3. Preferences menuButtonInToolPane ifTrue: [aRow addMorphFront: self menuButton]. self optionalButtonPairs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton useRoundedCorners; hResizing: #spaceFill; vResizing: #spaceFill; onColor: Color transparent offColor: Color transparent. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]) " font: (StrikeFont familyName: 'Atlanta' size: 9)". tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. tuple size > 3 ifTrue: [aButton triggerOnMouseDown: tuple fourth]. aRow addMorphBack: aButton]. aRow addMorphBack: self codePaneProvenanceButton. ^ aRow! ! !CodeHolder methodsFor: 'controls' stamp: 'sw 11/13/2001 09:12'! sourceAndDiffsQuintsOnly "Answer a list of quintuplets representing information on the alternative views available in the code pane for the case where the only plausible choices are showing source or either of the two kinds of diffs" ^ #( (source togglePlainSource showingPlainSourceString 'source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'showDiffs' 'the textual source diffed from its prior version') (prettyDiffs togglePrettyDiffing showingPrettyDiffsString 'prettyDiffs' 'formatted textual source diffed from formatted form of prior version'))! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'! defaultDiffsSymbol "Answer the code symbol to use when generically switching to diffing" ^ Preferences diffsWithPrettyPrint ifTrue: [#prettyDiffs] ifFalse: [#showDiffs]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:09'! diffButton "Return a checkbox that lets the user decide whether diffs should be shown or not. Not sent any more but retained against the possibility of existing subclasses outside the base image using it." | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleRegularDiffing; getSelector: #showingRegularDiffs. outerButton addMorphBack: (StringMorph contents: 'diffs') lock. outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/20/2001 21:14'! diffFromPriorSourceFor: sourceCode "If there is a prior version of source for the selected method, return a diff, else just return the source code" | prior | ^ (prior _ self priorSourceOrNil) ifNil: [sourceCode] ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode inClass: self selectedClass prettyDiffs: self showingPrettyDiffs]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 6/8/2001 00:37'! prettyDiffButton "Return a checkbox that lets the user decide whether prettyDiffs should be shown or not" | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #togglePrettyDiffing; getSelector: #showingPrettyDiffs. outerButton addMorphBack: (StringMorph contents: 'prettyDiffs') lock. (self isKindOf: VersionsBrowser) ifTrue: [outerButton setBalloonText: 'If checked, then pretty-printed code differences from the previous version, if any, will be shown.'] ifFalse: [outerButton setBalloonText: 'If checked, then pretty-printed code differences between the file-based method and the in-memory version, if any, will be shown.']. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:37'! regularDiffButton "Return a checkbox that lets the user decide whether regular diffs should be shown or not" | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleRegularDiffing; getSelector: #showingRegularDiffs. outerButton addMorphBack: (StringMorph contents: 'diffs') lock. outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. ^ outerButton ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:54'! restoreTextualCodingPane "If the receiver is showing tiles, restore the textual coding pane" self showingTiles ifTrue: [contentsSymbol _ #source. self installTextualCodingPane]! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:49'! showDiffs "Answer whether the receiver is showing diffs of source code. The preferred protocol here is #showingRegularDiffs, but this message is still sent by some preexisting buttons so is retained." ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:36'! showDiffs: aBoolean "Set whether I'm showing diffs as indicated; use the global preference to determine which kind of diffs to institute." self showingAnyKindOfDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ self defaultDiffsSymbol]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 18:25'! showPrettyDiffs: aBoolean "Set whether I'm showing pretty diffs as indicated" self showingPrettyDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ #prettyDiffs]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:50'! showRegularDiffs: aBoolean "Set whether I'm showing regular diffs as indicated" self showingRegularDiffs ifFalse: [aBoolean ifTrue: [contentsSymbol _ #showDiffs]] ifTrue: [aBoolean ifFalse: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 9/5/2001 13:32'! showingAnyKindOfDiffs "Answer whether the receiver is currently set to show any kind of diffs" ^ #(showDiffs prettyDiffs) includes: contentsSymbol! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 09:10'! showingDiffsString "Answer a string representing whether I'm showing diffs. Not sent any more but retained so that prexisting buttons that sent this will not raise errors." ^ (self showingRegularDiffs ifTrue: [''] ifFalse: ['']), 'showDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:07'! showingPrettyDiffs "Answer whether the receiver is showing pretty diffs of source code" ^ contentsSymbol == #prettyDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/22/2001 16:41'! showingPrettyDiffsString "Answer a string representing whether I'm showing pretty diffs" ^ (self showingPrettyDiffs ifTrue: [''] ifFalse: ['']), 'prettyDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:07'! showingRegularDiffs "Answer whether the receiver is showing regular diffs of source code" ^ contentsSymbol == #showDiffs ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:43'! showingRegularDiffsString "Answer a string representing whether I'm showing regular diffs" ^ (self showingRegularDiffs ifTrue: [''] ifFalse: ['']), 'showDiffs'! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 23:50'! toggleColorPrint "Toggle whether color-print is in effect in the code pane" self restoreTextualCodingPane. self okToChange ifTrue: [self showingColorPrint ifTrue: [contentsSymbol _ #source] ifFalse: [contentsSymbol _ #colorPrint]. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:30'! toggleDiffing "Toggle whether diffs should be shown in the code pane. If any kind of diffs were being shown, stop showing diffs. If no kind of diffs were being shown, start showing whatever kind of diffs are called for by default." | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingAnyKindOfDiffs. self restoreTextualCodingPane. self showDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:57'! togglePlainSource "Toggle whether plain source shown in the code pane" | wasShowingPlainSource | self okToChange ifTrue: [wasShowingPlainSource _ self showingPlainSource. self restoreTextualCodingPane. wasShowingPlainSource ifTrue: [self showDocumentation: true] ifFalse: [contentsSymbol _ #source]. self setContentsToForceRefetch. self changed: #contents] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/19/2001 00:02'! togglePrettyDiffing "Toggle whether pretty-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingPrettyDiffs. self restoreTextualCodingPane. self showPrettyDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 5/18/2001 19:54'! togglePrettyPrint "Toggle whether pretty-print is in effectin the code pane" self restoreTextualCodingPane. self okToChange ifTrue: [self showingPrettyPrint ifTrue: [contentsSymbol _ #source] ifFalse: [contentsSymbol _ #prettyPrint]. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:27'! toggleRegularDiffing "Toggle whether regular-diffing should be shown in the code pane" | wasShowingDiffs | self okToChange ifTrue: [wasShowingDiffs _ self showingRegularDiffs. self restoreTextualCodingPane. self showRegularDiffs: wasShowingDiffs not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'diffs' stamp: 'sw 11/13/2001 07:24'! wantsDiffFeedback "Answer whether the receiver is showing diffs of source code" ^ self showingAnyKindOfDiffs! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:52'! getSelectorAndSendQuery: querySelector to: queryPerformer "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained as its argument. If no message is currently selected, then obtain a method name from a user type-in" self getSelectorAndSendQuery: querySelector to: queryPerformer with: { }. ! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 4/10/2001 07:53'! getSelectorAndSendQuery: querySelector to: queryPerformer with: queryArgs "Obtain a selector relevant to the current context, and then send the querySelector to the queryPerformer with the selector obtained and queryArgs as its arguments. If no message is currently selected, then obtain a method name from a user type-in" | strm array | strm _ WriteStream on: (array _ Array new: queryArgs size + 1). strm nextPut: nil. strm nextPutAll: queryArgs. self selectedMessageName ifNil: [ | selector | selector _ FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. ^ selector isEmptyOrNil ifFalse: [ (Symbol hasInterned: selector ifTrue: [ :aSymbol | array at: 1 put: aSymbol. queryPerformer perform: querySelector withArguments: array]) ifFalse: [ self inform: 'no such selector'] ] ]. self selectMessageAndEvaluate: [:selector | array at: 1 put: selector. queryPerformer perform: querySelector withArguments: array ]! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:49'! isThereAnOverride "Answer whether any subclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. aClass allSubclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'nk 7/6/2003 07:52'! isThisAnOverride "Answer whether any superclass of my selected class implements my selected selector" | aName aClass | aName _ self selectedMessageName ifNil: [^ false]. aClass _ self selectedClassOrMetaClass. aClass allSuperclassesDo: [ :cls | (cls includesSelector: aName) ifTrue: [ ^true ]]. ^ false! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 8/1/2001 11:08'! menuButton "Answer a button that brings up a menu. Useful when adding new features, but at present is between uses" | aButton | aButton _ IconicButton new target: self; borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: #TinyMenu); color: Color transparent; actWhen: #buttonDown; actionSelector: #offerMenu; yourself. aButton setBalloonText: 'click here to get a menu with further options'. ^ aButton ! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 9/27/2001 01:26'! modelWakeUpIn: aWindow "The window has been activated. Respond to possible changes that may have taken place while it was inactive" self updateListsAndCodeIn: aWindow. self decorateButtons. self refreshAnnotation. super modelWakeUpIn: aWindow! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 11/13/2001 07:42'! okayToAccept "Answer whether it is okay to accept the receiver's input" self showingDocumentation ifTrue: [self inform: 'Sorry, for the moment you can only submit changes here when you are showing source. Later, you will be able to edit the isolated comment here and save it back, but only if YOU implement it!!.'. ^ false]. self showingAnyKindOfDiffs ifFalse: [^ true]. ^ SelectionMenu confirm: 'Caution!! You are "showing diffs" here, so there is a danger that some of the text in the code pane is contaminated by the "diff" display' trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider' ! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 10/28/2001 00:15'! refreshAnnotation "If the receiver has an annotation pane that does not bear unaccepted edits, refresh it" (self dependents detect: [:m | (m inheritsFromAnyIn: #('PluggableTextView' 'PluggableTextMorph')) and: [m getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo: [:aPane | aPane hasUnacceptedEdits ifFalse: [aPane update: #annotation]]! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 5/22/2001 16:47'! refusesToAcceptCode "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to" ^ (#(byteCodes documentation altSyntax tiles) includes: self contentsSymbol)! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 3/19/2001 06:06'! sendQuery: querySelector to: queryPerformer "Apply a query to the primary selector associated with the current context. If no such selection exists, obtain one by user type-in. Then send querySelector to queryPerformer with the selector as its argument." | aSelector aString | aSelector _ self selectedMessageName ifNil: [aString _FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. ^ aString isEmptyOrNil ifFalse: [(Symbol hasInterned: aString ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]. queryPerformer perform: querySelector with: aSelector! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 2/22/2001 06:37'! suggestCategoryToSpawnedBrowser: aBrowser "aBrowser is a message-category browser being spawned from the receiver. Tell it what it needs to know to get its category info properly set up." aBrowser setOriginalCategoryIndexForCurrentMethod! ! !CodeHolder methodsFor: 'misc' stamp: 'sw 3/20/2001 09:26'! useSelector: incomingSelector orGetSelectorAndSendQuery: querySelector to: queryPerformer "If incomingSelector is not nil, use it, else obtain a selector from user type-in. Using the determined selector, send the query to the performer provided." | aSelector | incomingSelector ifNotNil: [queryPerformer perform: querySelector with: incomingSelector] ifNil: [aSelector _FillInTheBlank request: 'Type selector:' initialAnswer: 'flag:'. aSelector isEmptyOrNil ifFalse: [(Symbol hasInterned: aSelector ifTrue: [:aSymbol | queryPerformer perform: querySelector with: aSymbol]) ifFalse: [self inform: 'no such selector']]]! ! !CodeHolder methodsFor: 'self-updating' stamp: 'nk 4/29/2004 12:25'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass aSelector aCompiledMethod | currentCompiledMethod ifNil: [^ false]. (aClass := self selectedClassOrMetaClass) ifNil: [^ false]. (aSelector := self selectedMessageName) ifNil: [^ false]. self classCommentIndicated ifTrue: [^ currentCompiledMethod ~~ aClass organization commentRemoteStr]. ^ (aCompiledMethod := aClass compiledMethodAt: aSelector ifAbsent: [^ false]) ~~ currentCompiledMethod and: [aCompiledMethod last ~= 0 "either not yet installed" or: [ currentCompiledMethod last = 0 "or these methods don't have source pointers"]]! ! !CodeHolder methodsFor: 'self-updating' stamp: 'sw 2/14/2001 15:34'! updateCodePaneIfNeeded "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" self didCodeChangeElsewhere ifTrue: [self hasUnacceptedEdits ifFalse: [self setContentsToForceRefetch. self contentsChanged] ifTrue: [self changed: #codeChangedElsewhere]]! ! !CodeHolder methodsFor: 'what to show' stamp: 'nk 6/19/2004 16:59'! addContentsTogglesTo: aMenu "Add updating menu toggles governing contents to aMenu." self contentsSymbolQuints do: [:aQuint | aQuint == #- ifTrue: [aMenu addLine] ifFalse: [Smalltalk isMorphic ifTrue: [aMenu addUpdating: aQuint third target: self action: aQuint second. aMenu balloonTextForLastItem: aQuint fifth] ifFalse: [aMenu add: (('*' match: (self perform: aQuint third)) ifTrue: ['*'] ifFalse: ['']), aQuint fourth target: self selector: #contentsSymbol: argumentList: { aQuint first } ]]]! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! colorPrintString "Answer whether the receiver is showing colorPrint" ^ (self showingColorPrint ifTrue: [''] ifFalse: ['']) , 'colorPrint'! ! !CodeHolder methodsFor: 'what to show' stamp: 'yo 2/17/2005 18:09'! offerWhatToShowMenu "Offer a menu governing what to show" | aMenu | Smalltalk isMorphic ifTrue: [aMenu := MenuMorph new defaultTarget: self. aMenu addTitle: 'What to show' translated. aMenu addStayUpItem. self addContentsTogglesTo: aMenu. aMenu popUpInWorld] ifFalse: [aMenu := CustomMenu new. self addContentsTogglesTo: aMenu. aMenu title: 'What to show' translated. aMenu invokeOn: self. self changed: #contents ]! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:36'! prettyPrintString "Answer whether the receiver is showing pretty-print" ^ ((contentsSymbol == #prettyPrint) ifTrue: [''] ifFalse: ['']), 'prettyPrint'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 2/14/2001 15:25'! setContentsToForceRefetch "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" contents _ nil! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:26'! showAltSyntax: aBoolean "Set the decompile toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#altSyntax])! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 21:13'! showByteCodes: aBoolean "Get into or out of bytecode-showoing mode" self okToChange ifFalse: [^ self changed: #flash]. aBoolean ifTrue: [contentsSymbol _ #byteCodes] ifFalse: [contentsSymbol == #byteCodes ifTrue: [contentsSymbol _ #source]]. self contentsChanged! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:14'! showDecompile: aBoolean "Set the decompile toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:27'! showingAltSyntax "Answer whether the receiver should show alt syntax rather than, say, source code" ^ self contentsSymbol == #altSyntax ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 16:37'! showingAltSyntaxString "Answer a string characerizing whether altSyntax is showing" ^ (self showingAltSyntax ifTrue: [''] ifFalse: ['']), 'altSyntax'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:05'! showingByteCodes "Answer whether the receiver is showing bytecodes" ^ contentsSymbol == #byteCodes! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 18:28'! showingByteCodesString "Answer whether the receiver is showing bytecodes" ^ (self showingByteCodes ifTrue: [''] ifFalse: ['']), 'byteCodes'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 23:50'! showingColorPrint "Answer whether the receiver is showing color-pretty-print" ^ contentsSymbol == #colorPrint! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:52'! showingDecompile "Answer whether the receiver should show decompile rather than, say, source code" ^ self contentsSymbol == #decompile ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:50'! showingDecompileString "Answer a string characerizing whether decompilation is showing" ^ (self showingDecompile ifTrue: [''] ifFalse: ['']), 'decompile'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:05'! showingDocumentationString "Answer a string characerizing whether documentation is showing" ^ (self showingDocumentation ifTrue: [''] ifFalse: ['']), 'documentation'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 19:43'! showingPlainSource "Answer whether the receiver is showing plain source" ^ contentsSymbol == #source! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/22/2001 09:31'! showingPlainSourceString "Answer a string telling whether the receiver is showing plain source" ^ (self showingPlainSource ifTrue: [''] ifFalse: ['']), 'source'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 18:36'! showingPrettyPrint "Answer whether the receiver is showing pretty-print" ^ contentsSymbol == #prettyPrint! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:28'! toggleAltSyntax "Toggle the setting of the showingAltSyntax flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingAltSyntax. self restoreTextualCodingPane. self showAltSyntax: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:48'! toggleDecompile "Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingDecompile. self restoreTextualCodingPane. self showDecompile: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:15'! toggleShowDocumentation "Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing _ self showingDocumentation. self restoreTextualCodingPane. self showDocumentation: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:09'! toggleShowingByteCodes "Toggle whether the receiver is showing bytecodes" self restoreTextualCodingPane. self showByteCodes: self showingByteCodes not. self setContentsToForceRefetch. self contentsChanged! ! !CodeHolder methodsFor: 'tiles' stamp: 'yo 2/17/2005 18:14'! addModelItemsToWindowMenu: aMenu "Add model-related item to the window menu" super addModelItemsToWindowMenu: aMenu. Smalltalk isMorphic ifTrue: [aMenu addLine. aMenu add: 'what to show...' translated target: self action: #offerWhatToShowMenu]! ! !CodeHolder methodsFor: 'tiles' stamp: 'RAA 5/20/2001 10:27'! installTextualCodingPane "Install text into the code pane" | aWindow codePane aPane boundsToUse | (aWindow _ self containingWindow) ifNil: [self error: 'where''s that window?']. codePane _ aWindow findDeepSubmorphThat: [:m | ((m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]) or: [m isKindOf: PluggableTileScriptorMorph]] ifAbsent: [self error: 'no code pane']. aPane _ self buildMorphicCodePaneWith: nil. boundsToUse _ (codePane bounds origin- (1@1)) corner: (codePane owner bounds corner " (1@1"). aWindow replacePane: codePane with: aPane. aPane vResizing: #spaceFill; hResizing: #spaceFill; borderWidth: 0. aPane bounds: boundsToUse. aPane owner clipSubmorphs: false. self contentsChanged! ! !CodeHolder methodsFor: 'tiles' stamp: 'nk 4/28/2004 10:14'! installTilesForSelection "Install universal tiles into the code pane." | source aSelector aClass tree syn tileScriptor aWindow codePane | (aWindow _ self containingWindow) ifNil: [self error: 'hamna dirisha']. tileScriptor _ ((aSelector _ self selectedMessageName) isNil or: [(aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector) isNil]) ifTrue: [PluggableTileScriptorMorph new] ifFalse: [source _ aClass sourceCodeAt: aSelector. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. syn inAPluggableScrollPane]. codePane _ aWindow findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]] ifAbsent: []. codePane ifNotNil: [codePane hideScrollBars]. codePane ifNil: [codePane _ aWindow findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph] ifAbsent: [self error: 'no code pane']]. tileScriptor color: aWindow paneColorToUse; setProperty: #hideUnneededScrollbars toValue: true. aWindow replacePane: codePane with: tileScriptor. currentCompiledMethod _ aClass ifNotNil: [aClass compiledMethodAt: aSelector]. tileScriptor owner clipSubmorphs: true. tileScriptor extent: codePane extent! ! !CodeHolder methodsFor: 'tiles' stamp: 'rhi 1/4/2002 11:15'! showTiles: aBoolean "Set the showingTiles as indicated. The fact that there are initially no senders of this reflects that fact that initially this trait is only directly settable through the UI; later there may be senders, such as if one wanted to set a system up so that all newly-opened browsers showed tiles rather than text." aBoolean ifTrue: [contentsSymbol _ #tiles] ifFalse: [contentsSymbol == #tiles ifTrue: [contentsSymbol _ #source]]. self setContentsToForceRefetch. self changed: #contents! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 2/3/2001 00:10'! showingTiles "Answer whether the receiver is currently showing tiles" ^ contentsSymbol == #tiles ! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 5/20/2001 21:12'! showingTilesString "Answer a string characterizing whether tiles are currently showing or not" ^ (self showingTiles ifTrue: [''] ifFalse: ['']), 'tiles'! ! !CodeHolder methodsFor: 'tiles' stamp: 'sw 2/14/2001 15:27'! toggleShowingTiles "Toggle whether tiles should be shown in the code pane" self okToChange ifTrue: [self showingTiles ifTrue: [contentsSymbol _ #source. self setContentsToForceRefetch. self installTextualCodingPane. self contentsChanged] ifFalse: [contentsSymbol _ #tiles. self installTilesForSelection. self changed: #tiles]]! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:17'! listPaneWithSelector: aSelector "If, among my window's paneMorphs, there is a list pane defined with aSelector as its retriever, answer it, else answer nil" | aWindow | ^ (aWindow _ self containingWindow) ifNotNil: [aWindow paneMorphSatisfying: [:aMorph | (aMorph isKindOf: PluggableListMorph) and: [aMorph getListSelector == aSelector]]]! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 12/1/2000 20:44'! newSearchPane "Answer a new search pane for the receiver" | aTextMorph | aTextMorph _ PluggableTextMorph on: self text: #lastSearchString accept: #lastSearchString: readSelection: nil menu: nil. aTextMorph setProperty: #alwaysAccept toValue: true. aTextMorph askBeforeDiscardingEdits: false. aTextMorph acceptOnCR: true. aTextMorph setBalloonText: 'Type here and hit ENTER, and all methods whose selectors match what you typed will appear in the list pane below.'. ^ aTextMorph! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:22'! searchPane "Answer the search pane associated with the receiver in its window, or nil if none. Morphic only" ^ self textPaneWithSelector: #lastSearchString! ! !CodeHolder methodsFor: 'categories & search pane' stamp: 'sw 3/7/2001 12:21'! textPaneWithSelector: aSelector "If, among my window's paneMorphs, there is a text pane defined with aSelector as its retriever, answer it, else answer nil" | aWindow | ^ (aWindow _ self containingWindow) ifNotNil: [aWindow paneMorphSatisfying: [:aMorph | (aMorph isKindOf: PluggableTextMorph) and: [aMorph getTextSelector == aSelector]]]! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:50'! decompiledSourceIntoContents "For backwards compatibility." ^self decompiledSourceIntoContentsWithTempNames: (Sensor leftShiftDown not) ! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:41'! decompiledSourceIntoContentsWithTempNames: showTempNames "Obtain a source string by decompiling the method's code, and place that source string into my contents. Also return the string. Get temps from source file if showTempNames is true." | tempNames class selector method | class := self selectedClassOrMetaClass. selector := self selectedMessageName. "Was method deleted while in another project?" method := class compiledMethodAt: selector ifAbsent: [^ '']. currentCompiledMethod := method. (showTempNames not or: [method fileIndex > 0 and: [(SourceFiles at: method fileIndex) isNil]]) ifTrue: [ "Emergency or no source file -- decompile without temp names " contents := (class decompilerClass new decompile: selector in: class method: method) decompileString] ifFalse: [tempNames := (class compilerClass new parse: method getSourceFromFile asString in: class notifying: nil) tempNames. contents := ((class decompilerClass new withTempNames: tempNames) decompile: selector in: class method: method) decompileString]. contents := contents asText makeSelectorBoldIn: class. ^ contents copy! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 8/16/2002 23:23'! selectedBytecodes "Answer text to show in a code pane when in showing-byte-codes mode" ^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName ifAbsent: [^ '' asText]) symbolic asText! ! !CodeHolder methodsFor: 'message list' stamp: 'nk 6/19/2004 16:46'! selectedMessage "Answer a copy of the source code for the selected message. This generic version is probably actually never reached, since every subclass probably reimplements and does not send to super. In time, ideally, most, or all, reimplementors would vanish and all would defer instead to a universal version right here. Everything in good time." | class selector method | contents ifNotNil: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. class _ self selectedClassOrMetaClass. (class isNil or: [(selector _ self selectedMessageName) isNil]) ifTrue: [^ '']. method _ class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod _ method. ^ contents _ (self showComment ifFalse: [self sourceStringPrettifiedAndDiffed] ifTrue: [ self commentContents]) copy asText makeSelectorBoldIn: class! ! !CodeHolder methodsFor: 'message list' stamp: 'sw 7/23/2002 13:05'! sourceStringPrettifiedAndDiffed "Answer a copy of the source code for the selected message, transformed by diffing and pretty-printing exigencies" | class selector sourceString | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. (class isNil or: [selector isNil]) ifTrue: [^ 'missing']. sourceString _ class ultimateSourceCodeAt: selector ifAbsent: [^ 'error']. self validateMessageSource: sourceString forSelector: selector. (#(prettyPrint colorPrint prettyDiffs altSyntax) includes: contentsSymbol) ifTrue: [sourceString _ class compilerClass new format: sourceString in: class notifying: nil contentsSymbol: contentsSymbol]. self showingAnyKindOfDiffs ifTrue: [sourceString _ self diffFromPriorSourceFor: sourceString]. ^ sourceString! ! !CodeHolder methodsFor: 'message list' stamp: 'sd 9/30/2003 14:01'! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass compilerClass == Object compilerClass and: [(sourceString asString findString: aSelector keywords first ) ~= 1]) ifTrue: [sourcesName _ FileDirectory localNameFor: SmalltalkImage current sourcesName. self inform: 'There may be a problem with your sources file!! The source code for every method should (usually) start with the method selector but this is not the case with this method!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "' , sourcesName , '" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again. (Occasionally, the source code for a method may legitimately start with a non-alphabetic character -- for example, Behavior method #formalHeaderPartsFor:. In such rare cases, you can happily disregard this warning.)'].! ! !CodeHolder methodsFor: 'message list menu' stamp: 'yo 7/5/2004 11:36'! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | aChar == $D ifTrue: [^ self toggleDiffing]. sel _ self selectedMessageName. aChar == $m ifTrue: "These next two put up a type in if no message selected" [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllImplementorsOf: to: self systemNavigation]. aChar == $n ifTrue: [^ self useSelector: sel orGetSelectorAndSendQuery: #browseAllCallsOn: to: self systemNavigation]. "The following require a class selection" (class _ self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $p ifTrue: [^ self browseFullProtocol]. "The following require a method selection" sel ifNotNil: [aChar == $o ifTrue: [^ self fileOutMessage]. aChar == $c ifTrue: [^ self copySelector]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $O ifTrue: [^ self openSingleMessageBrowser]. aChar == $x ifTrue: [^ self removeMessage]. aChar == $d ifTrue: [^ self removeMessageFromBrowser]. (aChar == $C and: [self canShowMultipleMessageCategories]) ifTrue: [^ self showHomeCategory]]. ^ self arrowKey: aChar from: view! ! !CodeHolder methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:19'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ false! ! !CodeLoader methodsFor: 'installing' stamp: 'RAA 2/19/2001 08:23'! installProject "Assume that we're loading a single file and it's a project" | aStream | aStream _ sourceFiles first contentStream. aStream ifNil:[^self error:'Project was not loaded']. ProjectLoading openName: nil "<--do we want to cache this locally? Need a name if so" stream: aStream fromDirectory: nil withProjectView: nil. ! ! !CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'! installSegment: reqEntry "Install the previously loaded segment" | contentStream contents trusted | contentStream _ reqEntry value contentStream. contentStream ifNil:[^self error:'No content to install: ', reqEntry key printString]. trusted _ SecurityManager default positionToSecureContentsOf: contentStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ contentStream close. ^self error:'Insecure content encountered: ', reqEntry key printString]]. contents _ contentStream ascii upToEnd unzipped. (contentStream respondsTo: #close) ifTrue:[contentStream close]. ^(RWBinaryOrTextStream with: contents) reset fileInObjectAndCode install.! ! !CodeLoader methodsFor: 'installing' stamp: 'sd 1/30/2004 15:16'! installSourceFile: aStream "Install the previously loaded source file" | contents trusted | aStream ifNil:[^self error:'No content to install']. trusted _ SecurityManager default positionToSecureContentsOf: aStream. trusted ifFalse:[(SecurityManager default enterRestrictedMode) ifFalse:[ aStream close. ^ self error:'Insecure content encountered']]. contents _ aStream ascii upToEnd unzipped. (aStream respondsTo: #close) ifTrue:[aStream close]. ^(RWBinaryOrTextStream with: contents) reset fileIn! ! !CodeLoader methodsFor: 'private' stamp: 'mir 2/2/2001 14:44'! createRequestFor: name in: aLoader "Create a URL request for the given string, which can be cached locally." | request | request _ HTTPLoader httpRequestClass for: self baseURL , name in: aLoader. aLoader addRequest: request. "fetch from URL" ^request! ! !CodeLoader methodsFor: 'private' stamp: 'avi 4/30/2004 01:40'! httpRequestClass ^HTTPDownloadRequest! ! !CodeLoader class methodsFor: 'utilities' stamp: 'mir 2/2/2001 14:56'! loadCodeSegment: segmentName | loader | loader _ self new. loader loadSegments: (Array with: segmentName). loader installSegments.! ! !CodeLoader class methodsFor: 'utilities' stamp: 'asm 12/6/2002 08:11'! signFile: fileName renameAs: destFile key: privateKey dsa: dsa "Sign the given file using the private key." | in out | in _ FileStream readOnlyFileNamed: fileName. in binary. out _ FileStream newFileNamed: destFile. out binary. [in atEnd] whileFalse:[out nextPutAll: (in next: 4096)]. in close. out close. FileDirectory activeDirectoryClass splitName: destFile to:[:path :file| SecurityManager default signFile: file directory: (FileDirectory on: path). ]. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ads 7/31/2003 14:00'! signFilesFrom: sourceNames to: destNames key: privateKey "Sign all the given files using the private key. This will add an 's' to the extension of the file." "| fd oldNames newNames | fd _ FileDirectory default directoryNamed:'unsigned'. oldNames _ fd fileNames. newNames _ oldNames collect:[:name| 'signed', FileDirectory slash, name]. oldNames _ oldNames collect:[:name| 'unsigned', FileDirectory slash, name]. CodeLoader signFilesFrom: oldNames to: newNames key: DOLPrivateKey." | dsa | dsa _ DigitalSignatureAlgorithm new. dsa initRandomNonInteractively. 'Signing files...' displayProgressAt: Sensor cursorPoint from: 1 to: sourceNames size during:[:bar| 1 to: sourceNames size do:[:i| bar value: i. self signFile: (sourceNames at: i) renameAs: (destNames at: i) key: privateKey dsa: dsa]]. ! ! !CodeLoader class methodsFor: 'utilities' stamp: 'ar 2/6/2001 19:17'! verifySignedFileNamed: aFileName "CodeLoader verifySignedFileNamed: 'signed\dummy1.dsq' " | secured signedFileStream | signedFileStream _ FileStream fileNamed: aFileName. secured _ SecurityManager default positionToSecureContentsOf: signedFileStream. signedFileStream close. Transcript show: aFileName , ' verified: '; show: secured printString; cr. ! ! !CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 1.0 g: 0.806 b: 0.677! ! !CodecDemoMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:20'! initialize "initialize the state of the receiver" super initialize. "" self codecClassName: 'MuLawCodec'! ! !CodecDemoMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'select codec' translated action: #selectCodec. ! ! !CollapsedMorph methodsFor: 'collapse/expand' stamp: 'sw 4/9/2001 14:23'! uncollapseToHand "Hand the uncollapsedMorph to the user, placing it in her hand, after remembering appropriate state for possible future use" | nakedMorph | nakedMorph _ uncollapsedMorph. uncollapsedMorph _ nil. nakedMorph setProperty: #collapsedPosition toValue: self position. mustNotClose _ false. "so the delete will succeed" self delete. ActiveHand attachMorph: nakedMorph! ! !CollapsedMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:41'! buildWindowMenu "Answer the menu to be put up in response to the user's clicking on the window-menu control in the window title. Specialized for CollapsedMorphs." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu add: 'change name...' translated action: #relabel. aMenu addLine. aMenu add: 'send to back' translated action: #sendToBack. aMenu add: 'make next-to-topmost' translated action: #makeSecondTopmost. aMenu addLine. self mustNotClose ifFalse: [aMenu add: 'make unclosable' translated action: #makeUnclosable] ifTrue: [aMenu add: 'make closable' translated action: #makeClosable]. aMenu add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) translated action: #toggleStickiness. ^aMenu! ! !CollapsedMorph methodsFor: 'queries' stamp: 'sw 4/9/2001 12:53'! isMyUncollapsedMorph: aMorph "Answer whether my uncollapsed morph is aMorph" ^ uncollapsedMorph == aMorph! ! !CollapsedMorph methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'! wantsExpandBox "Answer whether I'd like an expand box" ^ false! ! !CollapsedMorph class methodsFor: 'as yet unclassified' stamp: 'sw 4/9/2001 14:19'! collapsedMorphOrNilFor: anActualMorph "If there is any instance of the receiver that represents anActualMorph, answer it, else answer nil" self allInstances do: [:cm | (cm isMyUncollapsedMorph: anActualMorph) ifTrue: [^ cm]]. ^ nil! ! !Collection methodsFor: 'accessing' stamp: 'sd 11/4/2003 22:05'! atRandom "Answer a random element of the receiver. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use #atRandom:. Causes an error if self has no elements." ^ self class mutexForPicking critical: [ self atRandom: self class randomForPicking ] "Examples: #('one' 'or' 'the' 'other') atRandom (1 to: 10) atRandom 'Just pick one of these letters at random' atRandom #(3 7 4 9 21) asSet atRandom (just to show it also works for Sets) "! ! !Collection methodsFor: 'adapting' stamp: 'mk 10/27/2003 21:48'! adaptToComplex: rcvr andSend: selector "If I am involved in arithmetic with a scalar, return a Collection of the results of each element combined with the scalar in that expression." ^ self collect: [:element | rcvr perform: selector with: element]! ! !Collection methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 00:17'! raisedTo: arg ^ arg adaptToCollection: self andSend: #raisedTo:! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 20:30'! asIdentitySkipList "Answer a IdentitySkipList whose elements are the elements of the receiver. The sort order is the default less than or equal." ^ self as: IdentitySkipList! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:47'! asSkipList "Answer a SkipList whose elements are the elements of the receiver. The sort order is the default less than or equal." ^ self as: SkipList! ! !Collection methodsFor: 'converting' stamp: 'LC 6/18/2001 18:46'! asSkipList: aSortBlock "Answer a SkipList whose elements are the elements of the receiver. The sort order is defined by the argument, aSortBlock." | skipList | skipList _ SortedCollection new: self size. skipList sortBlock: aSortBlock. skipList addAll: self. ^ skipList! ! !Collection methodsFor: 'converting' stamp: 'hg 12/26/2001 23:53'! topologicallySortedUsing: aSortBlock "Answer a SortedCollection whose elements are the elements of the receiver, but topologically sorted. The topological order is defined by the argument, aSortBlock." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection sortBlock: aSortBlock. self do: [:each | aSortedCollection addLast: each]. "avoids sorting" ^ aSortedCollection sortTopologically ! ! !Collection methodsFor: 'copying' stamp: 'al 12/12/2003 14:31'! , aCollection ^self copy addAll: aCollection; yourself! ! !Collection methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement "Answer a new collection with newElement added (as last element if sequenceable)." ^self copyWith: newElement! ! !Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! collect: collectBlock thenDo: doBlock "Utility method to improve readability." ^ (self collect: collectBlock) do: doBlock! ! !Collection methodsFor: 'enumerating' stamp: 'gh 9/18/2001 15:59'! noneSatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns false for all elements return true. Otherwise return false" self do: [:item | (aBlock value: item) ifTrue: [^ false]]. ^ true! ! !Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! reject: rejectBlock thenDo: doBlock "Utility method to improve readability." ^ (self reject: rejectBlock) do: doBlock! ! !Collection methodsFor: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! select: selectBlock thenDo: doBlock "Utility method to improve readability." ^ (self select: selectBlock) do: doBlock! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcCos ^self collect: [:each | each arcCos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcSin ^self collect: [:each | each arcSin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! arcTan ^self collect: [:each | each arcTan]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! cos ^self collect: [:each | each cos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:20'! degreeCos ^self collect: [:each | each degreeCos]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! degreeSin ^self collect: [:each | each degreeSin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! exp ^self collect: [:each | each exp]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:21'! ln ^self collect: [:each | each ln]! ! !Collection methodsFor: 'math functions' stamp: 'nk 12/30/2003 15:47'! roundTo: quantum ^self collect: [ :ea | ea roundTo: quantum ]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:23'! sign ^self collect: [:each | each sign]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! sin ^self collect: [:each | each sin]! ! !Collection methodsFor: 'math functions' stamp: 'raok 10/22/2002 00:22'! tan ^self collect: [:each | each tan]! ! !Collection methodsFor: 'private' stamp: 'yo 6/29/2004 13:14'! errorNotKeyed self error: ('Instances of {1} do not respond to keyed accessing messages.' translated format: {self class name}) ! ! !Collection methodsFor: 'testing' stamp: 'jf 12/1/2003 15:37'! ifEmpty: aBlock "Evaluate the block if I'm empty" ^ self isEmpty ifTrue: aBlock! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:49'! ifEmpty: emptyBlock ifNotEmpty: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" " If the notEmptyBlock has an argument, eval with the receiver as its argument" ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock valueWithPossibleArgument: self]! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'! ifEmpty: emptyBlock ifNotEmptyDo: notEmptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise" "Evaluate the notEmptyBlock with the receiver as its argument" ^ self isEmpty ifTrue: emptyBlock ifFalse: [notEmptyBlock value: self]! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:58'! ifNotEmpty: aBlock "Evaluate the given block unless the receiver is empty. If the block has an argument, eval with the receiver as its argument, but it might be better to use ifNotEmptyDo: to make the code easier to understand" ^self isEmpty ifFalse: [aBlock valueWithPossibleArgument: self]. ! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:48'! ifNotEmpty: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise If the notEmptyBlock has an argument, eval with the receiver as its argument" ^ self isEmpty ifFalse: [notEmptyBlock valueWithPossibleArgument: self] ifTrue: emptyBlock! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 14:28'! ifNotEmptyDo: aBlock "Evaluate the given block with the receiver as its argument." ^self isEmpty ifFalse: [aBlock value: self]. ! ! !Collection methodsFor: 'testing' stamp: 'md 10/7/2004 15:36'! ifNotEmptyDo: notEmptyBlock ifEmpty: emptyBlock "Evaluate emptyBlock if I'm empty, notEmptyBlock otherwise Evaluate the notEmptyBlock with the receiver as its argument" ^ self isEmpty ifFalse: [notEmptyBlock value: self] ifTrue: emptyBlock! ! !Collection methodsFor: 'testing' stamp: 'nk 8/30/2004 07:49'! includesSubstringAnywhere: testString "Answer whether the receiver includes, anywhere in its nested structure, a string that has testString as a substring" self do: [:element | (element isString) ifTrue: [(element includesSubString: testString) ifTrue: [^ true]]. (element isCollection) ifTrue: [(element includesSubstringAnywhere: testString) ifTrue: [^ true]]]. ^ false "#(first (second third) ((allSentMessages ('Elvis' includes:)))) includesSubstringAnywhere: 'lvi'"! ! !Collection methodsFor: 'testing' stamp: 'dgd 4/4/2004 12:14'! isZero "Answer whether the receiver is zero" ^ false! ! !Collection methodsFor: '*packageinfo-base' stamp: 'ab 9/30/2002 19:26'! gather: aBlock ^ Array streamContents: [:stream | self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:07'! initialize "Set up a Random number generator to be used by atRandom when the user does not feel like creating his own Random generator." RandomForPicking _ Random new. MutexForPicking _ Semaphore forMutualExclusion! ! !Collection class methodsFor: 'private' stamp: 'lr 11/4/2003 12:08'! mutexForPicking ^ MutexForPicking! ! !CollectionTest methodsFor: 'initialize-release' stamp: 'st 10/7/2004 16:23'! setUp empty := Set new. nonEmpty := OrderedCollection with: #x! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:23'! testIfEmptyifNotEmpty self assert: (empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [true]). self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [:s | s first = #x])! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:23'! testIfEmptyifNotEmptyDo self assert: (empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). self assert: (nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | s first = #x])! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:24'! testIfNotEmpty empty ifNotEmpty: [self assert: false]. self assert: (nonEmpty ifNotEmpty: [self]) == self. self assert: (nonEmpty ifNotEmpty: [:s | s first]) = #x ! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:24'! testIfNotEmptyDo empty ifNotEmptyDo: [:s | self assert: false]. self assert: (nonEmpty ifNotEmptyDo: [:s | s first]) = #x ! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:24'! testIfNotEmptyDoifNotEmpty self assert: (empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). self assert: (nonEmpty ifNotEmptyDo: [:s | s first = #x] ifEmpty: [false])! ! !CollectionTest methodsFor: 'testing' stamp: 'st 10/7/2004 16:24'! testIfNotEmptyifEmpty self assert: (empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [true]). self assert: (nonEmpty ifEmpty: [false] ifNotEmpty: [:s | s first = #x])! ! !CollectionTest commentStamp: '' prior: 0! A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs. When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp. When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.! !Color methodsFor: 'queries' stamp: 'sw 9/27/2001 17:26'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Color! ! !Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! isOpaque ^true! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! adjustBrightness: brightness "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ Color h: self hue s: self saturation v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! adjustSaturation: saturation brightness: brightness "Adjust the relative saturation and brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ Color h: self hue s: (self saturation + saturation min: 1.0 max: 0.005) v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'transformations' stamp: 'nk 3/8/2004 09:43'! atMostAsLuminentAs: aFloat | revisedColor | revisedColor _ self. [revisedColor luminance > aFloat] whileTrue: [revisedColor _ revisedColor slightlyDarker]. ^revisedColor ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! blacker ^ self alphaMixed: 0.8333 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! dansDarker "Return a darker shade of the same color. An attempt to do better than the current darker method. (now obsolete, since darker has been changed to do this. -dew)" ^ Color h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! darker "Answer a darker shade of this color." ^ self adjustBrightness: -0.08! ! !Color methodsFor: 'transformations' stamp: 'dew 3/8/2002 00:13'! duller ^ self adjustSaturation: -0.03 brightness: -0.2! ! !Color methodsFor: 'transformations' stamp: 'dew 1/23/2002 20:19'! lighter "Answer a lighter shade of this color." ^ self adjustSaturation: -0.03 brightness: 0.08! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! muchDarker ^ self alphaMixed: 0.5 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:42'! paler "Answer a paler shade of this color." ^ self adjustSaturation: -0.09 brightness: 0.09 ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyDarker ^ self adjustBrightness: -0.03 ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyLighter ^ self adjustSaturation: -0.01 brightness: 0.03! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! slightlyWhiter ^ self alphaMixed: 0.85 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:44'! twiceDarker "Answer a significantly darker shade of this color." ^ self adjustBrightness: -0.15! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! twiceLighter "Answer a significantly lighter shade of this color." ^ self adjustSaturation: -0.06 brightness: 0.15! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! whiter ^ self alphaMixed: 0.8333 with: Color white ! ! !Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ self! ! !Color methodsFor: 'conversions' stamp: 'st 9/27/2004 13:42'! asHTMLColor ^ '#', (self class hex: self red), (self class hex: self green), (self class hex: self blue)! ! !Color methodsFor: 'conversions' stamp: 'bf 4/18/2001 16:25'! makeForegroundColor "Make a foreground color contrasting with me" ^self luminance >= 0.5 ifTrue: [Color black] ifFalse: [Color white]! ! !Color methodsFor: 'conversions' stamp: 'ar 5/15/2001 16:12'! pixelValue32 "Note: pixelWord not pixelValue so we include translucency" ^self pixelWordForDepth: 32! ! !Color methodsFor: 'conversions' stamp: 'jm 1/26/2001 15:11'! pixelValueForDepth: d "Returns an integer representing the bits that appear in a single pixel of this color in a Form of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32. Contrast with pixelWordForDepth: and bitPatternForDepth:, which return either a 32-bit word packed with the given pixel value or a multiple-word Bitmap containing a pattern. The inverse is the class message colorFromPixelValue:depth:" "Details: For depths of 8 or less, the result is a colorMap index. For depths of 16 and 32, it is a direct color value with 5 or 8 bits per color component." "Transparency: The pixel value zero is reserved for transparent. For depths greater than 8, black maps to the darkest possible blue." | rgbBlack val | d = 8 ifTrue: [^ self closestPixelValue8]. "common case" d < 8 ifTrue: [ d = 4 ifTrue: [^ self closestPixelValue4]. d = 2 ifTrue: [^ self closestPixelValue2]. d = 1 ifTrue: [^ self closestPixelValue1]]. rgbBlack _ 1. "closest black that is not transparent in RGB" d = 16 ifTrue: [ "five bits per component; top bits ignored" val _ (((rgb bitShift: -15) bitAnd: 16r7C00) bitOr: ((rgb bitShift: -10) bitAnd: 16r03E0)) bitOr: ((rgb bitShift: -5) bitAnd: 16r001F). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. d = 32 ifTrue: [ "eight bits per component; top 8 bits set to all ones (opaque alpha)" val _ LargePositiveInteger new: 4. val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF). val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF). val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF). val = 0 ifTrue: [val at: 1 put: 1]. "closest non-transparent black" val at: 4 put: 16rFF. "opaque alpha" ^ val]. d = 12 ifTrue: [ "for indexing a color map with 4 bits per color component" val _ (((rgb bitShift: -18) bitAnd: 16r0F00) bitOr: ((rgb bitShift: -12) bitAnd: 16r00F0)) bitOr: ((rgb bitShift: -6) bitAnd: 16r000F). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. d = 9 ifTrue: [ "for indexing a color map with 3 bits per color component" val _ (((rgb bitShift: -21) bitAnd: 16r01C0) bitOr: ((rgb bitShift: -14) bitAnd: 16r0038)) bitOr: ((rgb bitShift: -7) bitAnd: 16r0007). ^ val = 0 ifTrue: [rgbBlack] ifFalse: [val]]. self error: 'unknown pixel depth: ', d printString ! ! !Color methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 12:10'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change color...' translated target: self selector: #changeColorIn:event: argument: aMorph! ! !Color class methodsFor: 'instance creation' stamp: 'st 9/27/2004 13:45'! colorFrom: parm "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol or, if it is a list, it can either be an array of three numbers, which will be interpreted as RGB values, or a list of symbols, the first of which is sent to me and then the others of which are in turn sent to the prior result, thus allowing entries of the form #(blue darker). Else just return the thing" | aColor firstParm | (parm isKindOf: Color) ifTrue: [^ parm]. (parm isKindOf: Symbol) ifTrue: [^ self perform: parm]. (parm isKindOf: String) ifTrue: [^ self fromString: parm]. ((parm isKindOf: SequenceableCollection) and: [parm size > 0]) ifTrue: [firstParm := parm first. (firstParm isKindOf: Number) ifTrue: [^ self fromRgbTriplet: parm]. aColor := self colorFrom: firstParm. parm doWithIndex: [:sym :ind | ind > 1 ifTrue: [aColor := aColor perform: sym]]. ^ aColor]. ^ parm " Color colorFrom: #(blue darker) Color colorFrom: Color blue darker Color colorFrom: #blue Color colorFrom: #(0.0 0.0 1.0) "! ! !Color class methodsFor: 'instance creation' stamp: 'tk 8/15/2001 11:03'! colorFromPixelValue: p depth: d "Convert a pixel value for the given display depth into a color." "Details: For depths of 8 or less, the pixel value is simply looked up in a table. For greater depths, the color components are extracted and converted into a color." | r g b alpha | d = 8 ifTrue: [^ IndexedColors at: (p bitAnd: 16rFF) + 1]. d = 4 ifTrue: [^ IndexedColors at: (p bitAnd: 16r0F) + 1]. d = 2 ifTrue: [^ IndexedColors at: (p bitAnd: 16r03) + 1]. d = 1 ifTrue: [^ IndexedColors at: (p bitAnd: 16r01) + 1]. (d = 16) | (d = 15) ifTrue: [ "five bits per component" r _ (p bitShift: -10) bitAnd: 16r1F. g _ (p bitShift: -5) bitAnd: 16r1F. b _ p bitAnd: 16r1F. (r = 0 and: [g = 0]) ifTrue: [ b = 0 ifTrue: [^Color transparent]. b = 1 ifTrue: [^Color black]]. ^ Color r: r g: g b: b range: 31]. d = 32 ifTrue: [ "eight bits per component; 8 bits of alpha" r _ (p bitShift: -16) bitAnd: 16rFF. g _ (p bitShift: -8) bitAnd: 16rFF. b _ p bitAnd: 16rFF. alpha _ p bitShift: -24. alpha = 0 ifTrue: [^Color transparent]. (r = 0 and: [g = 0 and: [b = 0]]) ifTrue: [^Color transparent]. alpha < 255 ifTrue: [^ (Color r: r g: g b: b range: 255) alpha: (alpha asFloat / 255.0)] ifFalse: [^ (Color r: r g: g b: b range: 255)]]. d = 12 ifTrue: [ "four bits per component" r _ (p bitShift: -8) bitAnd: 16rF. g _ (p bitShift: -4) bitAnd: 16rF. b _ p bitAnd: 16rF. ^ Color r: r g: g b: b range: 15]. d = 9 ifTrue: [ "three bits per component" r _ (p bitShift: -6) bitAnd: 16r7. g _ (p bitShift: -3) bitAnd: 16r7. b _ p bitAnd: 16r7. ^ Color r: r g: g b: b range: 7]. self error: 'unknown pixel depth: ', d printString ! ! !Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! h: h s: s v: v alpha: alpha ^ (self h: h s: s v: v) alpha: alpha! ! !Color class methodsFor: 'other' stamp: 'st 9/27/2004 13:41'! hex: aFloat "Return an hexadecimal two-digits string between 00 and FF for a float between 0.0 and 1.0" | str | str := ((aFloat * 255) asInteger hex allButFirst: 3) asLowercase. str size = 1 ifTrue: [^'0',str] ifFalse: [^str]! ! !Color class methodsFor: 'color from user' stamp: 'ka 2/18/2005 02:29'! colorPaletteForDepth: depth extent: chartExtent "Display a palette of colors sorted horizontally by hue and vertically by lightness. Useful for eyeballing the color gamut of the display, or for choosing a color interactively." "Note: It is slow to build this palette, so it should be cached for quick access." "(Color colorPaletteForDepth: 16 extent: 190@60) display" | basicHue x y c startHue palette transHt vSteps transCaption grayWidth hSteps formTranslator noColorForm | formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID. noColorForm := formTranslator translate: 'no color'. noColorForm ifNil: [noColorForm := Form extent: 34 @ 9 depth: 1 fromArray: #(0 0 256 0 256 0 3808663859 2147483648 2491688266 2147483648 2491688266 0 2491688266 0 2466486578 0 0 0 ) offset: 0 @ 0]. palette _ Form extent: chartExtent depth: depth. transCaption _ "(DisplayText text: 'no color' asText textStyle: (TextConstants at: #ComicPlain)) form storeString" noColorForm. transHt _ transCaption height. palette fillWhite: (0@0 extent: palette width@transHt). palette fillBlack: (0@transHt extent: palette width@1). transCaption displayOn: palette at: palette boundingBox topCenter - ((transCaption width // 2)@0). grayWidth _ 10. startHue _ 338.0. vSteps _ palette height - transHt // 2. hSteps _ palette width - grayWidth. x _ 0. startHue to: startHue + 360.0 by: 360.0/hSteps do: [:h | basicHue _ Color h: h asFloat s: 1.0 v: 1.0. y _ transHt+1. 0 to: vSteps do: [:n | c _ basicHue mixed: (n asFloat / vSteps asFloat) with: Color white. palette fill: (x@y extent: 1@1) fillColor: c. y _ y + 1]. 1 to: vSteps do: [:n | c _ Color black mixed: (n asFloat / vSteps asFloat) with: basicHue. palette fill: (x@y extent: 1@1) fillColor: c. y _ y + 1]. x _ x + 1]. y _ transHt + 1. 1 to: vSteps * 2 do: [:n | c _ Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. palette fill: (x@y extent: 10@1) fillColor: c. y _ y + 1]. ^ palette ! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'! at: index ^(super at: index) asColorOfDepth: 32! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'! at: index put: aColor ^super at: index put: (aColor pixelWordForDepth: 32).! ! !ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! asColorArray ^self! ! !ColorArray methodsFor: 'converting' stamp: 'RAA 3/8/2001 06:24'! bytesPerElement ^4! ! !ColorForm methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! colors: colorList "Set my color palette to the given collection." | colorArray colorCount newColors | colorList ifNil: [ colors _ cachedDepth _ cachedColormap _ nil. ^ self]. colorArray _ colorList asArray. colorCount _ colorArray size. newColors _ Array new: (1 bitShift: self depth). 1 to: newColors size do: [:i | i <= colorCount ifTrue: [newColors at: i put: (colorArray at: i)] ifFalse: [newColors at: i put: Color transparent]]. colors _ newColors. cachedDepth _ nil. cachedColormap _ nil. ! ! !ColorForm methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:32'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm aDisplayMedium copyBits: self boundingBox from: self at: aDisplayPoint + self offset clippingBox: clipRectangle rule: rule fillColor: aForm map: (self colormapIfNeededFor: aDisplayMedium). ! ! !ColorForm methodsFor: 'displaying' stamp: 'ar 12/14/2001 18:14'! maskingMap "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." | maskingMap | maskingMap _ Bitmap new: (1 bitShift: depth) withAll: 16rFFFFFFFF. 1 to: colors size do:[:i| (colors at: i) isTransparent ifTrue:[maskingMap at: i put: 0]. ]. colors size+1 to: maskingMap size do:[:i| maskingMap at: i put: 0]. ^maskingMap! ! !ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededForDepth: destDepth "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." | newMap | colors == nil ifTrue: [ "use the standard colormap" ^ Color colorMapIfNeededFrom: self depth to: destDepth]. (destDepth = cachedDepth and:[cachedColormap isColormap not]) ifTrue: [^ cachedColormap]. newMap _ Bitmap new: colors size. 1 to: colors size do: [:i | newMap at: i put: ((colors at: i) pixelValueForDepth: destDepth)]. cachedDepth _ destDepth. ^ cachedColormap _ newMap. ! ! !ColorForm methodsFor: 'copying' stamp: 'di 11/12/2001 15:37'! blankCopyOf: aRectangle scaledBy: scale | newForm | newForm _ super blankCopyOf: aRectangle scaledBy: scale. colors ifNotNil: [newForm colors: colors copy]. ^ newForm! ! !ColorForm methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'! ensureColorArrayExists "Return my color palette." colors ifNil: [ self depth > 8 ifTrue: [^ self error: 'ColorForms only support depths up to 8 bits']. self colors: (Color indexedColors copyFrom: 1 to: (1 bitShift: self depth))]. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'! hibernate "Make myself take up less space. See comment in Form>hibernate." super hibernate. self clearColormapCache. colors ifNotNil:[colors _ colors asColorArray].! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:46'! readAttributesFrom: aBinaryStream super readAttributesFrom: aBinaryStream. colors _ ColorArray new: (2 raisedTo: depth). 1 to: colors size do: [:idx | colors basicAt: idx put: (aBinaryStream nextLittleEndianNumber: 4). ]. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 20:07'! unhibernate colors ifNotNil:[colors _ colors asArray]. ^super unhibernate. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:42'! writeAttributesOn: file | colorArray | super writeAttributesOn: file. colorArray _ self colors asColorArray. 1 to: (2 raisedTo: depth) do: [:idx | file nextLittleEndianNumber: 4 put: (colorArray basicAt: idx). ] ! ! !ColorForm methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:44'! colormapIfNeededFor: destForm | newMap color pv | (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifFalse:[ ^self colormapIfNeededForDepth: destForm depth. ]. colors == nil ifTrue: [ "use the standard colormap" ^ super colormapIfNeededFor: destForm]. (destForm depth = cachedDepth and:[cachedColormap isColormap]) ifTrue: [^ cachedColormap]. newMap _ WordArray new: (1 bitShift: self depth). 1 to: colors size do: [:i | color _ colors at: i. pv _ destForm pixelValueFor: color. (pv = 0 and:[color isTransparent not]) ifTrue:[pv _ 1]. newMap at: i put: pv]. cachedDepth _ destForm depth. ^cachedColormap _ ColorMap shifts: nil masks: nil colors: newMap.! ! !ColorForm methodsFor: 'testing' stamp: 'ar 5/27/2001 16:34'! isColorForm ^true! ! !ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm class methodsFor: 'as yet unclassified' stamp: 'nk 4/17/2004 19:44'! mappingWhiteToTransparentFrom: aFormOrCursor "Return a ColorForm copied from the given Form or Cursor with white mapped to transparent." | f map | aFormOrCursor depth <= 8 ifFalse: [ ^ self error: 'argument depth must be 8-bits per pixel or less']. (aFormOrCursor isColorForm) ifTrue: [ f _ aFormOrCursor deepCopy. map _ aFormOrCursor colors. ] ifFalse: [ f _ ColorForm extent: aFormOrCursor extent depth: aFormOrCursor depth. f copyBits: aFormOrCursor boundingBox from: aFormOrCursor at: 0@0 clippingBox: aFormOrCursor boundingBox rule: Form over fillColor: nil. map _ Color indexedColors copyFrom: 1 to: (1 bitShift: aFormOrCursor depth)]. map _ map collect: [:c | c = Color white ifTrue: [Color transparent] ifFalse: [c]]. f colors: map. ^ f ! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'! mapPixel: pixelValue "Perform a forward pixel mapping operation" | pv | (shifts == nil and:[masks == nil]) ifFalse:[ pv _ (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)). ] ifTrue:[pv _ pixelValue]. colors ifNotNil:[pv _ colors at: pv]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]]. ^pv! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 5/15/2001 16:12'! pixelMap: pixelValue "Perform a reverse pixel mapping operation" | pv | colors == nil ifTrue:[pv _ pixelValue] ifFalse:[pv _ colors at: pixelValue]. (shifts == nil and:[masks == nil]) ifFalse:[pv _ (((pv bitAnd: self redMask) bitShift: self redShift) bitOr: ((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pv bitAnd: self alphaMask) bitShift: self alphaShift))]. "Need to check for translucency else Form>>paint goes gaga" pv = 0 ifTrue:[pixelValue = 0 ifFalse:[pv _ 1]]. ^pv! ! !ColorMap methodsFor: 'comparing' stamp: 'tk 7/5/2001 21:59'! = aColorMap "Return true if the receiver is equal to aColorMap" self species == aColorMap species ifFalse:[^false]. self isIndexed == aColorMap isIndexed ifFalse:[^false]. ^self colors = aColorMap colors and:[ self shifts = aColorMap shifts and:[ self masks = aColorMap masks]]! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/4/2001 15:59'! masks: maskArray shifts: shiftArray ^self shifts: shiftArray masks: maskArray colors: nil.! ! !ColorMappingCanvas methodsFor: 'drawing-polygons' stamp: 'mir 9/12/2001 14:24'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc "Draw the given polygon." ^myCanvas drawPolygon: vertices color: aColor borderWidth: bw borderColor: (self mapColor: bc)! ! !ColorMappingCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." myCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: (self mapColor: c)! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! on: aCanvas myCanvas _ aCanvas.! ! !ColorMappingCanvas methodsFor: 'testing' stamp: 'ar 8/8/2001 14:16'! isShadowDrawing ^myCanvas isShadowDrawing! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the given form. For the 'paint' combination rule use stenciling otherwise simply fill the source rectangle." ^myCanvas image: aForm at: aPoint sourceRect: sourceRect rule: rule.! ! !ColorMappingCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:15'! mapColor: aColor ^aColor! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 8/25/2001 20:44'! locationIndicator | loc | ^self valueOfProperty: #locationIndicator ifAbsent:[ loc _ EllipseMorph new. loc color: Color transparent; borderWidth: 1; borderColor: Color red; extent: 6@6. self setProperty: #locationIndicator toValue: loc. self addMorphFront: loc. loc]! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'gm 2/22/2003 13:12'! originalColor: colorOrSymbol "Set the receiver's original color. It is at this point that a command is launched to represent the action of the picker, in support of Undo." originalColor := (colorOrSymbol isColor) ifTrue: [colorOrSymbol] ifFalse: [Color lightGreen]. originalForm fill: RevertBox fillColor: originalColor. selectedColor := originalColor. self locationIndicator center: self topLeft + (self positionOfColor: originalColor)! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'aoy 2/15/2003 21:24'! target: anObject target := anObject. selectedColor := (target respondsTo: #color) ifTrue: [target color] ifFalse: [Color white]! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:16'! inhibitDragging ^self hasProperty: #noDraggingThisPicker! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'RAA 2/19/2001 13:17'! mouseDown: evt | localPt | localPt _ evt cursorPoint - self topLeft. self deleteAllBalloons. clickedTranslucency _ TransparentBox containsPoint: localPt. self inhibitDragging ifFalse: [ (DragBox containsPoint: localPt) ifTrue: [^ evt hand grabMorph: self]. ]. (RevertBox containsPoint: localPt) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. self inhibitDragging ifFalse: [self comeToFront]. sourceHand _ evt hand. self startStepping. ! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'ar 9/4/2001 13:26'! initialize "Initialize the receiver. Obey the modalColorPickers preference when deciding how to configure myself. This is not quite satisfactory -- we'd like to have explicit calls tell us things like whether whether to be modal, whether to allow transparency, but for the moment, in grand Morphic fashion, this is rather inflexibly all housed right here" super initialize. self clipSubmorphs: true. self buildChartForm. selectedColor _ Color white. sourceHand _ nil. deleteOnMouseUp _ false. clickedTranslucency _ false. updateContinuously _ true. selector _ nil. target _ nil! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:17'! initializeForPropertiesPanel "Initialize the receiver. If beModal is true, it will be a modal color picker, else not" isModal _ false. self removeAllMorphs. self setProperty: #noDraggingThisPicker toValue: true. self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'restore original color' translated). self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'shows selected color' translated). self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated). self buildChartForm. selectedColor ifNil: [selectedColor _ Color white]. sourceHand _ nil. deleteOnMouseUp _ false. updateContinuously _ true. ! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'yo 2/23/2005 17:13'! initializeModal: beModal "Initialize the receiver. If beModal is true, it will be a modal color picker, else not" isModal _ beModal. self removeAllMorphs. isModal ifFalse: [theSelectorDisplayMorph _ AlignmentMorph newRow color: Color white; borderWidth: 1; borderColor: Color red; hResizing: #shrinkWrap; vResizing: #shrinkWrap; addMorph: (StringMorph contents: 'theSelector' translated). self addMorph: theSelectorDisplayMorph. self addMorph: (SimpleButtonMorph new borderWidth: 0; label: 'x' font: nil; color: Color transparent; actionSelector: #delete; target: self; useSquareCorners; position: self topLeft - (0@3); extent: 10@12; setCenteredBalloonText: 'dismiss color picker' translated)]. self addMorph: ((Morph newBounds: (DragBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'put me somewhere' translated). self addMorph: ((Morph newBounds: (RevertBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'restore original color' translated). self addMorph: ((Morph newBounds: (FeedbackBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'shows selected color' translated). self addMorph: ((Morph newBounds: (TransparentBox translateBy: self topLeft)) color: Color transparent; setCenteredBalloonText: 'adjust translucency' translated). self buildChartForm. selectedColor ifNil: [selectedColor _ Color white]. sourceHand _ nil. deleteOnMouseUp _ false. updateContinuously _ true. ! ! !ColorPickerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:17'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. deleteOnMouseUp ifTrue: [aCustomMenu add: 'stay up' translated action: #toggleDeleteOnMouseUp] ifFalse: [aCustomMenu add: 'do not stay up' translated action: #toggleDeleteOnMouseUp]. updateContinuously ifTrue: [aCustomMenu add: 'update only at end' translated action: #toggleUpdateContinuously] ifFalse: [aCustomMenu add: 'update continuously' translated action: #toggleUpdateContinuously]. ! ! !ColorPickerMorph methodsFor: 'menu' stamp: 'JMM 9/13/2004 09:41'! pickUpColorFor: aMorph "Show the eyedropper cursor, and modally track the mouse through a mouse-down and mouse-up cycle" | aHand localPt delay | aHand _ aMorph ifNil: [self activeHand] ifNotNil: [aMorph activeHand]. aHand ifNil: [aHand _ self currentHand]. self addToWorld: aHand world near: (aMorph ifNil: [aHand world]) fullBounds. self owner ifNil: [^ self]. aHand showTemporaryCursor: (ScriptingSystem formAtKey: #Eyedropper) hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" self updateContinuously: false. delay _ Delay forMilliseconds: 50. [Sensor anyButtonPressed] whileFalse: [self trackColorUnderMouse. delay wait]. self deleteAllBalloons. localPt _ Sensor cursorPoint - self topLeft. self inhibitDragging ifFalse: [ (DragBox containsPoint: localPt) ifTrue: ["Click or drag the drag-dot means to anchor as a modeless picker" ^ self anchorAndRunModeless: aHand]. ]. (clickedTranslucency _ TransparentBox containsPoint: localPt) ifTrue: [selectedColor _ originalColor]. self updateContinuously: true. [Sensor anyButtonPressed] whileTrue: [self updateTargetColorWith: self indicateColorUnderMouse]. aHand newMouseFocus: nil; showTemporaryCursor: nil; flushEvents. self delete. ! ! !ColorPickerMorph methodsFor: 'submorphs-add/remove' stamp: 'nk 4/17/2004 19:34'! delete "The moment of departure has come. If the receiver has an affiliated command, finalize it and have the system remember it. In any case, delete the receiver" (selector isNil or: [ target isNil ]) ifFalse: [ self rememberCommand: (Command new cmdWording: 'color change' translated; undoTarget: target selector: selector arguments: (self argumentsWith: originalColor); redoTarget: target selector: selector arguments: (self argumentsWith: selectedColor)). ]. super delete! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 7/19/2003 20:40'! argumentsWith: aColor "Return an argument array appropriate to this action selector" | nArgs | nArgs _ selector ifNil:[0] ifNotNil:[selector numArgs]. nArgs = 0 ifTrue:[^#()]. nArgs = 1 ifTrue:[^ {aColor}]. nArgs = 2 ifTrue:[^ {aColor. sourceHand}]. nArgs = 3 ifTrue:[^ {aColor. argument. sourceHand}]. ! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:59'! modalBalloonHelpAtPoint: cursorPoint self flag: #arNote. "Throw this away. There needs to be another way." self submorphsDo: [:m | m wantsBalloon ifTrue: [(m valueOfProperty: #balloon) isNil ifTrue: [(m containsPoint: cursorPoint) ifTrue: [m showBalloon: m balloonText]] ifFalse: [(m containsPoint: cursorPoint) ifFalse: [m deleteBalloon]]]]! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:43'! pickColorAt: aGlobalPoint | alpha selfRelativePoint pickedColor | clickedTranslucency ifNil: [clickedTranslucency _ false]. selfRelativePoint _ (self globalPointToLocal: aGlobalPoint) - self topLeft. (FeedbackBox containsPoint: selfRelativePoint) ifTrue: [^ self]. (RevertBox containsPoint: selfRelativePoint) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. "check for transparent color and update using appropriate feedback color " (TransparentBox containsPoint: selfRelativePoint) ifTrue: [clickedTranslucency ifFalse: [^ self]. "Can't wander into translucency control" alpha _ (selfRelativePoint x - TransparentBox left - 10) asFloat / (TransparentBox width - 20) min: 1.0 max: 0.0. "(alpha roundTo: 0.01) printString , ' ' displayAt: 0@0." " -- debug" self updateColor: (selectedColor alpha: alpha) feedbackColor: (selectedColor alpha: alpha). ^ self]. "pick up color, either inside or outside this world" clickedTranslucency ifTrue: [^ self]. "Can't wander out of translucency control" self locationIndicator visible: false. self refreshWorld. pickedColor _ Display colorAt: aGlobalPoint. self locationIndicator visible: true. self refreshWorld. self updateColor: ( (selectedColor isColor and: [selectedColor isTranslucentColor]) ifTrue: [pickedColor alpha: selectedColor alpha] ifFalse: [pickedColor] ) feedbackColor: pickedColor! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 9/4/2001 13:27'! positionOfColor: aColor "Compute the position of the given color in the color chart form" | rgbRect x y h s v | rgbRect _ (0@0 extent: originalForm boundingBox extent) insetBy: (1@10 corner: 11@1). h _ aColor hue. s _ aColor saturation. v _ aColor brightness. h = 0.0 ifTrue:["gray" ^(rgbRect right + 6) @ (rgbRect height * (1.0 - v) + rgbRect top)]. x _ (h + 22 \\ 360 / 360.0 * rgbRect width) rounded. y _ 0.5. s < 1.0 ifTrue:[y _ y - (1.0 - s * 0.5)]. v < 1.0 ifTrue:[y _ y + (1.0 - v * 0.5)]. y _ (y * rgbRect height) rounded. ^x@y + (1@10)! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 8/25/2001 20:50'! updateColor: aColor feedbackColor: feedbackColor "Set my selected color to the given color if it is different. Give user feedback. Inform the target of the change if the target and selector are not nil." selectedColor = aColor ifTrue: [^ self]. "do nothing if color doesn't change" self updateAlpha: aColor alpha. originalForm fill: FeedbackBox fillColor: feedbackColor. self form: originalForm. selectedColor _ aColor. updateContinuously ifTrue: [self updateTargetColor]. self locationIndicator center: self topLeft + (self positionOfColor: feedbackColor).! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'! updateTargetColor | nArgs | (target notNil and: [selector notNil]) ifTrue: [self updateSelectorDisplay. nArgs := selector numArgs. nArgs = 1 ifTrue: [^target perform: selector with: selectedColor]. nArgs = 2 ifTrue: [^target perform: selector with: selectedColor with: sourceHand]. nArgs = 3 ifTrue: [^target perform: selector with: selectedColor with: argument with: sourceHand]]! ! !ColorPickerMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:41'! updateTargetColorWith: aColor "Update the target so that it reflects aColor as the color choice" (target notNil and: [selector notNil]) ifTrue: [self updateSelectorDisplay. ^target perform: selector withArguments: (self argumentsWith: aColor)]! ! !ColorPickerMorph commentStamp: 'kfr 10/27/2003 16:16' prior: 0! A gui for setting color and transparency. Behaviour can be changed with the Preference modalColorPickers.! !ColorPickerMorph class methodsFor: 'class initialization' stamp: 'ka 2/19/2005 02:39'! initialize "ColorPickerMorph initialize" | formTranslator | ColorChart _ Color colorPaletteForDepth: 16 extent: 190@60. DragBox _ (11@0) extent: 9@8. RevertBox _ (ColorChart width - 20)@1 extent: 9@8. FeedbackBox _ (ColorChart width - 10)@1 extent: 9@8. TransparentBox _ DragBox topRight corner: RevertBox bottomLeft. ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1@9). ColorChart fillBlack: ((TransparentBox left)@0 extent: 1@9). ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1@9). ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1@9). (Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0@1). formTranslator := NaturalLanguageFormTranslator localeID: Locale current localeID. TransText := formTranslator translate: 'translucent'. TransText ifNil: [TransText := Form extent: 63 @ 8 depth: 1 fromArray: #(4194306 1024 4194306 1024 15628058 2476592640 4887714 2485462016 1883804850 2486772764 4756618 2485462016 4748474 1939416064 0 0) offset: 0 @ 0]. TransText _ ColorForm mappingWhiteToTransparentFrom: TransText ! ! !ColorSeerTile methodsFor: 'code generation' stamp: 'dgd 2/22/2003 14:25'! storeCodeOn: aStream indent: tabCount "We have a hidden arg. Output two keywords with interspersed arguments." | parts | parts := operatorOrExpression keywords. "color:sees:" ^aStream nextPutAll: (parts first); space; nextPutAll: colorSwatch color printString; space; nextPutAll: (parts second)! ! !ColorSeerTile methodsFor: 'initialization' stamp: 'mir 7/12/2004 20:23'! initialize "initialize the state of the receiver" | m1 m2 desiredW wording | super initialize. "" self removeAllMorphs. "get rid of the parts of a regular Color tile" type _ #operator. operatorOrExpression _ #color:sees:. wording _ (Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: []) wording. m1 _ StringMorph contents: wording font: ScriptingSystem fontForTiles. m2 _ Morph new extent: 12 @ 8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self basicWidth) @ self class defaultH. m1 position: bounds center x - (m1 width // 2) @ (bounds top + 5). m2 position: bounds center x - (m2 width // 2) + 3 @ (bounds top + 8). self addMorph: m1; addMorphFront: m2. colorSwatch _ m2! ! !ColorSeerTile methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:20'! updateWordingToMatchVocabulary "The current vocabulary has changed; change the wording on my face, if appropriate" | aMethodInterface | aMethodInterface _ self currentVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [Vocabulary eToyVocabulary methodInterfaceAt: operatorOrExpression ifAbsent: [^ self]]. self labelMorph contents: aMethodInterface wording. self setBalloonText: aMethodInterface helpMessage.! ! !ColorSwatch methodsFor: 'setting' stamp: 'sw 3/23/2001 12:12'! setTargetColor: aColor "Set the target color as indicated" putSelector ifNotNil: [self color: aColor. contents _ aColor. target perform: self putSelector withArguments: (Array with: argument with: aColor)] ! ! !ColorSwatch methodsFor: 'target access' stamp: 'dgd 2/22/2003 13:32'! readFromTarget "Obtain a value from the target and set it into my lastValue" | v | (target isNil or: [getSelector isNil]) ifTrue: [^contents]. v := target perform: getSelector with: argument. lastValue := v. ^v! ! !ColorTest methodsFor: 'testing' stamp: 'st 9/27/2004 13:43'! testAsHTMLColor self assert: (Color white asHTMLColor = '#ffffff'). self assert: (Color black asHTMLColor = '#000000').! ! !ColorTest methodsFor: 'testing' stamp: 'st 9/27/2004 13:45'! testColorFrom self assert: ((Color colorFrom: #white) asHTMLColor = '#ffffff'). self assert: ((Color colorFrom: #(1.0 0.5 0.0)) asHTMLColor = '#ff7f00'). self assert: ((Color colorFrom: (Color white)) asHTMLColor = '#ffffff'). self assert: ((Color colorFrom: '#FF8800') asHTMLColor = '#ff8800').! ! !ColorTest methodsFor: 'testing' stamp: 'st 9/27/2004 13:43'! testFromString self assert: ((Color fromString: '#FF8800') asHTMLColor = '#ff8800').! ! !ColorTileMorph methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:27'! resultType "Answer the result type of the receiver" ^ #Color! ! !ColorTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:44'! initialize "initialize the state of the receiver" super initialize. "" type _ #literal. self addColorSwatch! ! !ColorTileMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 17:33'! updateWordingToMatchVocabulary | stringMorph | stringMorph _ submorphs detect: [:morph | morph class == StringMorph] ifNone: [^ self]. stringMorph contents: 'color' translated. ! ! !ColorTileMorph methodsFor: 'other' stamp: 'yo 7/2/2004 17:33'! addColorSwatch | m1 m2 desiredW | m1 _ StringMorph contents: 'color' translated font: ScriptingSystem fontForTiles. m2 _ Morph new extent: 12@8; color: (Color r: 0.8 g: 0 b: 0). desiredW _ m1 width + 6. self extent: (desiredW max: self basicWidth) @ self class defaultH. m1 position: (bounds center x - (m1 width // 2)) @ (bounds top + 1). m2 position: (bounds center x - (m2 width // 2)) @ (m1 bottom - 1). self addMorph: m1; addMorph: m2. colorSwatch _ m2! ! !ColorType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ Color blue newTileMorphRepresentative! ! !ColorType methodsFor: 'tiles' stamp: 'sw 1/4/2005 00:39'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" | readout | readout _ UpdatingRectangleMorph new. readout getSelector: getter; target: aTarget; borderWidth: 1; extent: 22@22. (setter isNil or: [#(unused none #nil) includes: setter]) ifFalse: [readout putSelector: setter]. ^ readout ! ! !ColorType methodsFor: 'tiles' stamp: 'sw 1/5/2005 19:57'! wantsArrowsOnTiles "Answer whether this data type wants up/down arrows on tiles representing its values" ^ false! ! !ColorType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:28'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ Color random! ! !ColorType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:23'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Color.! ! !ColorType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(1.0 0 0.065) ! ! !ColorType commentStamp: 'sw 1/5/2005 22:15' prior: 0! A data type representing a Color value.! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'! add: char | dict elem | codes ifNil: [codes _ Array with: char. combined _ char. ^ true]. dict _ Compositions at: combined charCode ifAbsent: [^ false]. elem _ dict at: combined charCode ifAbsent: [^ false]. codes _ codes copyWith: char. combined _ elem. ^ true. ! ! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'! base ^ codes first. ! ! !CombinedChar methodsFor: 'as yet unclassified' stamp: 'yo 2/10/2004 07:08'! combined ^ combined. ! ! !CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:21'! isDiacriticals: unicode ^ Diacriticals includes: unicode. ! ! !CombinedChar class methodsFor: 'as yet unclassified' stamp: 'yo 12/31/2002 19:09'! parseCompositionMappingFrom: stream " self halt. self parseCompositionMapping " | line fieldEnd point fieldStart compositions toNumber diacritical result | toNumber _ [:quad | ('16r', quad) asNumber]. Compositions _ IdentityDictionary new: 2048. Decompositions _ IdentityDictionary new: 2048. Diacriticals _ IdentitySet new: 2048. [(line _ stream upTo: Character cr) size > 0] whileTrue: [ fieldEnd _ line indexOf: $; startingAt: 1. point _ ('16r', (line copyFrom: 1 to: fieldEnd - 1)) asNumber. 2 to: 6 do: [:i | fieldStart _ fieldEnd + 1. fieldEnd _ line indexOf: $; startingAt: fieldStart. ]. compositions _ line copyFrom: fieldStart to: fieldEnd - 1. (compositions size > 0 and: [compositions first ~= $<]) ifTrue: [ compositions _ compositions substrings collect: toNumber. compositions size > 1 ifTrue: [ diacritical _ compositions first. Diacriticals add: diacritical. result _ compositions second. (Decompositions includesKey: point) ifTrue: [ self error: 'should not happen'. ] ifFalse: [ Decompositions at: point put: (Array with: diacritical with: result). ]. (Compositions includesKey: diacritical) ifTrue: [ (Compositions at: diacritical) at: result put: point. ] ifFalse: [ Compositions at: diacritical put: (IdentityDictionary new at: result put: point; yourself). ]. ]. ]. ]. ! ! !Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! veryDeepFixupWith: deepCopier | old | "ALL inst vars were weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. 1 to: self class instSize do: [:ii | old _ self instVarAt: ii. self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. ! ! !Command methodsFor: 'copying' stamp: 'tk 2/25/2001 17:53'! veryDeepInner: deepCopier "ALL fields are weakly copied!! Can't duplicate an object by duplicating a Command that involves it. See DeepCopier." super veryDeepInner: deepCopier. "just keep old pointers to all fields" parameters _ parameters.! ]style[(25 108 10 103)f1b,f1,f1LDeepCopier Comment;,f1! ! !Command methodsFor: 'private' stamp: 'dgd 8/26/2003 21:43'! cmdWording "Answer the wording to be used to refer to the command in a menu" ^ cmdWording ifNil: ['last command' translated]! ! !CommandHistory methodsFor: 'called by programmer' stamp: 'aoy 2/15/2003 21:14'! purgeAllCommandsSuchThat: cmdBlock "Remove a bunch of commands, as in [:cmd | cmd undoTarget == zort]" Preferences useUndo ifFalse: [^self]. history := history reject: cmdBlock. lastCommand := history isEmpty ifTrue: [nil] ifFalse: [history last] ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! redoNextCommand "If there is a way to 'redo' (move FORWARD) in the undo/redo history tape, do it." | anIndex | lastCommand ifNil: [^ Beeper beep]. lastCommand phase == #undone ifFalse: [anIndex _ history indexOf: lastCommand. (anIndex < history size) ifTrue: [lastCommand _ history at: anIndex + 1] ifFalse: [^ Beeper beep]]. lastCommand redoCommand. lastCommand phase: #done ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! undoLastCommand "Undo the last command, i.e. move backward in the recent-commands tape, if possible." | aPhase anIndex | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifFalse: [aPhase == #undone ifTrue: [anIndex _ history indexOf: lastCommand. anIndex > 1 ifTrue: [lastCommand _ history at: anIndex - 1]]]. lastCommand undoCommand. lastCommand phase: #undone "Command undoLastCommand" ! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! undoOrRedoCommand "This gives a feature comparable to standard Mac undo/redo. If the undo/redo action taken was a simple do or a redo, then undo it. But if the last undo/redo action taken was an undo, then redo it." "Command undoOrRedoCommand" | aPhase | lastCommand ifNil: [^ Beeper beep]. (aPhase _ lastCommand phase) == #done ifTrue: [lastCommand undoCommand. lastCommand phase: #undone] ifFalse: [aPhase == #undone ifTrue: [lastCommand redoCommand. lastCommand phase: #done]]! ! !CommandHistory methodsFor: 'called from the ui' stamp: 'nb 6/17/2003 12:25'! undoTo "Not yet functional, and not yet sent. Allow the user to choose a point somewhere in the undo/redo tape, and undo his way to there. Applicable only if infiniteUndo is set. " | anIndex commandList aMenu reply | (anIndex _ self historyIndexOfLastCommand) == 0 ifTrue: [^ Beeper beep]. commandList _ history copyFrom: ((anIndex - 10) max: 1) to: ((anIndex + 10) min: history size). aMenu _ SelectionMenu labels: (commandList collect: [:cmd | cmd cmdWording truncateWithElipsisTo: 20]) selections: commandList. reply _ aMenu startUpWithCaption: 'undo or redo to...'. reply ifNotNil: [self inform: #deferred] "ActiveWorld commandHistory undoTo" ! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40'! redoMenuWording "Answer the wording to be used in a menu offering the current Redo command" | nextCommand | ((nextCommand := self nextCommand) isNil or: [Preferences useUndo not]) ifTrue: [^'can''t redo']. ^String streamContents: [:aStream | aStream nextPutAll: 'redo "'. aStream nextPutAll: (nextCommand cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifFalse: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:40'! undoMenuWording "Answer the wording to be used in an 'undo' menu item" (((lastCommand isNil or: [Preferences useUndo not]) or: [Preferences infiniteUndo not and: [lastCommand phase == #undone]]) or: [self nextCommandToUndo isNil]) ifTrue: [^'can''t undo']. ^String streamContents: [:aStream | aStream nextPutAll: 'undo "'. aStream nextPutAll: (self nextCommandToUndo cmdWording truncateWithElipsisTo: 20). aStream nextPut: $". lastCommand phase == #done ifTrue: [aStream nextPutAll: ' (z)']]! ! !CommandHistory methodsFor: 'menu' stamp: 'dgd 8/26/2003 21:42'! undoOrRedoMenuWording "Answer the wording to be used in a menu item offering undo/redo (i.e., the form used when the #infiniteUndo preference is false)" | pre | lastCommand ifNil: [^ 'can''t undo' translated]. pre _ lastCommand phase == #done ifTrue: ['undo' translated] ifFalse: ['redo' translated]. ^ pre, ' "', (lastCommand cmdWording truncateWithElipsisTo: 20), '" (z)'! ! !CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:52'! forgetAllGrabCommandsFrom: starter "Forget all the commands that might be held on to in the properties dicitonary of various morphs for various reasons." | object | object _ starter. [ [0 == object] whileFalse: [ object isMorph ifTrue: [object removeProperty: #undoGrabCommand]. object _ object nextObject]. ] ifError: [:err :rcvr | "object is obsolete" self forgetAllGrabCommandsFrom: object nextObject]. "CommandHistory forgetAllGrabCommandsFrom: true someObject" ! ! !CommandHistory class methodsFor: 'system startup' stamp: 'tk 5/16/2002 13:38'! resetAllHistory "Reset all command histories, and make all morphs that might be holding on to undo-grab-commands forget them" self allInstancesDo: [:c | c resetCommandHistory]. self forgetAllGrabCommandsFrom: self someObject. "CommandHistory resetAllHistory" ! ! !CommandLineLauncherExample methodsFor: 'running' stamp: 'sd 3/28/2003 16:24'! startUp | className | className _ self parameterAt: 'class'. Browser newOnClass: (Smalltalk at: className asSymbol ifAbsent: [Object])! ! !CommentedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:37'! isCommented ^true! ! !CommentedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:37'! printEventKindOn: aStream aStream nextPutAll: 'Commented'! ! !CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:08'! changeKind ^#Commented! ! !CommentedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'! supportedKinds ^Array with: self classKind! ! !CompiledMethod methodsFor: 'accessing' stamp: 'rw 5/12/2003 11:12'! defaultSelector "Invent and answer an appropriate message selector (a Symbol) for me, that is, one that will parse with the correct number of arguments." | aStream | aStream _ WriteStream on: (String new: 16). aStream nextPutAll: 'DoIt'. 1 to: self numArgs do: [:i | aStream nextPutAll: 'with:']. ^aStream contents asSymbol! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ls 7/5/2003 13:50'! flag "Answer the user-level flag bit" ^( (self header bitShift: -29) bitAnd: 1) = 1 ifTrue: [ true ] ifFalse: [ false ] ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'nk 3/15/2004 11:29'! methodReference | who | who _ self who. who = #(unknown unknown) ifTrue: [ ^nil ]. ^MethodReference new setStandardClass: who first methodSymbol: who second. ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ls 6/22/2000 14:35'! primitive "Answer the primitive index associated with the receiver. Zero indicates that this is not a primitive method. We currently allow 10 bits of primitive index, but they are in two places for backward compatibility. The time to unpack is negligible, since the reconstituted full index is stored in the method cache." | primBits | primBits _ self header bitAnd: 16r100001FF. ^ (primBits bitAnd: 16r1FF) + (primBits bitShift: -19) ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ajh 11/17/2001 14:30'! trailer | end trailer | end _ self endPC. trailer _ ByteArray new: self size - end. end + 1 to: self size do: [:i | trailer at: i - end put: (self at: i)]. ^ trailer! ! !CompiledMethod methodsFor: 'comparing' stamp: 'ar 8/16/2001 13:24'! = method | myLits otherLits | "Answer whether the receiver implements the same code as the argument, method." (method isKindOf: CompiledMethod) ifFalse: [^false]. self size = method size ifFalse: [^false]. self header = method header ifFalse: [^false]. self initialPC to: self endPC do: [:i | (self at: i) = (method at: i) ifFalse: [^false]]. (myLits _ self literals) = (otherLits _ method literals) ifFalse: [myLits size = otherLits size ifFalse: [^ false]. "Dont bother checking FFI and named primitives" (#(117 120) includes: self primitive) ifTrue: [^ true]. myLits with: otherLits do: [:lit1 :lit2 | lit1 = lit2 ifFalse: [(lit1 isVariableBinding) ifTrue: ["Associations match if value is equal, since associations used for super may have key = nil or name of class." lit1 value == lit2 value ifFalse: [^ false]] ifFalse: [(lit1 isMemberOf: Float) ifTrue: ["Floats match if values are close, due to roundoff error." (lit1 closeTo: lit2) ifFalse: [^ false]] ifFalse: ["any other discrepancy is a failure" ^ false]]]]]. ^ true! ! !CompiledMethod methodsFor: 'testing' stamp: 'sw 5/3/2001 15:06'! hasReportableSlip "Answer whether the receiver contains anything that should be brought to the attention of the author when filing out. Customize the lists here to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'checkForSlips' is set to true." | assoc | #(doOnlyOnce: halt halt: hottest printDirectlyToDisplay toRemove personal urgent) do: [:aLit | (self hasLiteral: aLit) ifTrue: [^ true]]. #(Transcript AA BB CC DD EE) do: [:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil: [(self hasLiteral: assoc) ifTrue: [^ true]]]. ^ false! ! !CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'! isCompiledMethod ^ true! ! !CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:24'! dateMethodLastSubmitted "Answer a Date object indicating when a method was last submitted. If there is no date stamp, return nil" "(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted" | aStamp tokens | aStamp _ self timeStamp. tokens _ aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 2/9/2003 14:17'! longPrintOn: aStream "List of all the byte codes in a method with a short description of each" self longPrintOn: aStream indent: 0! ! !CompiledMethod methodsFor: 'printing' stamp: 'ar 6/28/2003 00:08'! longPrintOn: aStream indent: tabs "List of all the byte codes in a method with a short description of each" self isQuick ifTrue: [self isReturnSpecial ifTrue: [^ aStream tab: tabs; nextPutAll: 'Quick return ' , (#('self' 'true' 'false' 'nil' '-1' '0' '1' '2') at: self primitive - 255)]. ^ aStream nextPutAll: 'Quick return field ' , self returnField printString , ' (0-based)']. self primitive = 0 ifFalse: [ aStream tab: tabs. self printPrimitiveOn: aStream. ]. (InstructionPrinter on: self) indent: tabs; printInstructionsOn: aStream. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ajh 3/20/2001 11:41'! symbolic "Answer a String that contains a list of all the byte codes in a method with a short description of each." | aStream | aStream _ WriteStream on: (String new: 1000). self longPrintOn: aStream. ^aStream contents! ! !CompiledMethod methodsFor: 'printing' stamp: 'yo 3/16/2004 12:29'! timeStamp "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." "(CompiledMethod compiledMethodAt: #timeStamp) timeStamp" | file preamble stamp tokens tokenCount | self fileIndex == 0 ifTrue: [^ String new]. "no source pointer for this method" file _ SourceFiles at: self fileIndex. file ifNil: [^ String new]. "sources file not available" "file does not exist happens in secure mode" file _ [file readOnlyCopy] on: FileDoesNotExistException do:[:ex| nil]. file ifNil: [^ String new]. preamble _ self getPreambleFrom: file at: (0 max: self filePosition - 3). stamp _ String new. tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [Scanner new scanTokens: preamble] ifFalse: [Array new "ie cant be back ref"]. (((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 3) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount - 2]]. ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount]]. file close. ^ stamp ! ! !CompiledMethod methodsFor: 'printing' stamp: 'dvf 8/23/2003 11:50'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | self systemNavigation allBehaviorsDo: [:class | (sel := class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^Array with: #unknown with: #unknown! ! !CompiledMethod methodsFor: 'literals' stamp: 'ajh 2/9/2003 13:15'! headerDescription "Answer a description containing the information about the form of the receiver and the form of the context needed to run the receiver." | s | s _ '' writeStream. self header printOn: s. s cr; nextPutAll: '"primitive: '. self primitive printOn: s. s cr; nextPutAll: ' numArgs: '. self numArgs printOn: s. s cr; nextPutAll: ' numTemps: '. self numTemps printOn: s. s cr; nextPutAll: ' numLiterals: '. self numLiterals printOn: s. s cr; nextPutAll: ' frameSize: '. self frameSize printOn: s. s cr; nextPutAll: ' isClosureCompiled: '. self isClosureCompiled printOn: s. s nextPut: $"; cr. ^ s contents! ! !CompiledMethod methodsFor: 'literals' stamp: 'ar 8/16/2001 13:24'! literalStrings | lits litStrs | lits _ self literals. litStrs _ OrderedCollection new: lits size * 3. self literals do: [:lit | (lit isVariableBinding) ifTrue: [litStrs addLast: lit key] ifFalse: [(lit isMemberOf: Symbol) ifTrue: [litStrs addAll: lit keywords] ifFalse: [litStrs addLast: lit printString]]]. ^ litStrs! ! !CompiledMethod methodsFor: 'source code management' stamp: 'di 1/7/2004 15:32'! copyWithTempNames: tempNames | tempStr compressed | tempStr _ String streamContents: [:strm | tempNames do: [:n | strm nextPutAll: n; space]]. compressed := self qCompress: tempStr firstTry: true. compressed ifNil: ["failure case (tempStr too big) will just decompile with tNN names" ^ self copyWithTrailerBytes: #(0 0 0 0)]. ^ self copyWithTrailerBytes: compressed! ! !CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:23'! getPreambleFrom: aFileStream at: position | writeStream | writeStream _ String new writeStream. position to: 0 by: -1 do: [:p | | c | aFileStream position: p. c _ aFileStream basicNext. c == $!! ifTrue: [^ writeStream contents reverse] ifFalse: [writeStream nextPut: c]]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 09:45'! holdsTempNames "Are tempNames stored in trailer bytes" | flagByte | flagByte _ self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 0)]]) ifTrue: [^ false]. "No source pointer & no temp names" flagByte < 252 ifTrue: [^ true]. "temp names compressed" ^ false "Source pointer" ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'NS 1/16/2004 15:39'! putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: preambleBlock "Store the source code for the receiver on an external file. If no sources are available, i.e., SourceFile is nil, then store temp names for decompilation at the end of the method. If the fileIndex is 1, print on *.sources; if it is 2, print on *.changes, in each case, storing a 4-byte source code pointer at the method end." | file remoteString st80str | (SourceFiles == nil or: [(file _ SourceFiles at: fileIndex) == nil]) ifTrue: [^ self become: (self copyWithTempNames: methodNode tempNames)]. SmalltalkImage current assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" (methodNode isKindOf: DialectMethodNode) ifTrue: ["This source was parsed from an alternate syntax. We must convert to ST80 before logging it." st80str _ (DialectStream dialect: #ST80 contents: [:strm | methodNode printOn: strm]) asString. remoteString _ RemoteString newString: st80str onFileNumber: fileIndex toFile: file] ifFalse: [remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file]. file nextChunkPut: ' '. InMidstOfFileinNotification signal ifFalse: [file flush]. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! ! !CompiledMethod methodsFor: 'source code management' stamp: 'yo 3/16/2004 12:48'! qCompress: string firstTry: firstTry "A very simple text compression routine designed for method temp names. Most common 12 chars get values 0-11 packed in one 4-bit nibble; others get values 12-15 (2 bits) * 16 plus next nibble. Last char of str must be a space so it may be dropped without consequence if output ends on odd nibble. Normal call is with firstTry == true." | charTable odd ix oddNibble names shorterStr maybe str temps | str _ string isOctetString ifTrue: [string] ifFalse: [temps _ string findTokens: ' '. String streamContents: [:stream | 1 to: temps size do: [:index | stream nextPut: $t. stream nextPutAll: index asString. stream space]]]. charTable _ "Character encoding table must match qDecompress:" ' eatrnoislcm bdfghjkpquvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'. ^ ByteArray streamContents: [:strm | odd _ true. "Flag for odd or even nibble out" oddNibble _ nil. str do: [:char | ix _ (charTable indexOf: char) - 1. (ix <= 12 ifTrue: [Array with: ix] ifFalse: [Array with: ix//16+12 with: ix\\16]) do: [:nibble | (odd _ odd not) ifTrue: [strm nextPut: oddNibble*16 + nibble] ifFalse: [oddNibble _ nibble]]]. strm position > 251 ifTrue: ["Only values 1...251 are available for the flag byte that signals compressed temps. See the logic in endPC." "Before giving up completely, we attempt to encode most of the temps, but with the last few shortened to tNN-style names." firstTry ifFalse: [^ nil "already tried --give up now"]. names _ str findTokens: ' '. names size < 8 ifTrue: [^ nil "weird case -- give up now"]. 4 to: names size//2 by: 4 do: [:i | shorterStr _ String streamContents: [:s | 1 to: names size - i do: [:j | s nextPutAll: (names at: j); space]. 1 to: i do: [:j | s nextPutAll: 't' , j printString; space]]. (maybe _ self qCompress: shorterStr firstTry: false) ifNotNil: [^ maybe]]. ^ nil]. strm nextPut: strm position] " | m s | m _ CompiledMethod new. s _ 'charTable odd ix oddNibble '. ^ Array with: s size with: (m qCompress: s) size with: (m qDecompress: (m qCompress: s)) " ! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:19'! sourceClass "Get my receiver class (method class) from the preamble of my source. Return nil if not found." ^ [(Compiler evaluate: (self sourceFileStream backChunk "blank"; backChunk "preamble")) theClass] on: Error do: [nil]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:18'! sourceFileStream "Answer the sources file stream with position set at the beginning of my source string" | pos | (pos _ self filePosition) = 0 ifTrue: [^ nil]. ^ (RemoteString newFileNumber: self fileIndex position: pos) fileStream! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 8/13/2002 18:28'! sourceSelector "Answer my selector extracted from my source. If no source answer nil" | sourceString | sourceString _ self getSourceFromFile ifNil: [^ nil]. ^ Compiler parserClass new parseSelector: sourceString! ! !CompiledMethod methodsFor: 'source code management' stamp: 'ajh 7/21/2003 00:29'! tempNames | byteCount bytes | self holdsTempNames ifFalse: [ ^ (1 to: self numTemps) collect: [:i | 't', i printString] ]. byteCount _ self at: self size. byteCount = 0 ifTrue: [^ Array new]. bytes _ (ByteArray new: byteCount) replaceFrom: 1 to: byteCount with: self startingAt: self size - byteCount. ^ (self qDecompress: bytes) findTokens: ' '! ! !CompiledMethod methodsFor: 'file in/out' stamp: 'RAA 8/21/2001 23:10'! zapSourcePointer "clobber the source pointer since it will be wrong" 0 to: 3 do: [ :i | self at: self size - i put: 0]. ! ! !CompiledMethod methodsFor: 'evaluating' stamp: 'ajh 1/28/2003 12:33'! valueWithReceiver: aReceiver arguments: anArray ^ aReceiver withArgs: anArray executeMethod: self! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/3/2003 21:18'! blockNode BlockNodeCache key == self ifTrue: [^ BlockNodeCache value]. ^ self blockNodeIn: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 5/28/2003 01:10'! blockNodeIn: homeMethodNode "Return the block node for self" homeMethodNode ifNil: [ ^ self decompilerClass new decompileBlock: self]. homeMethodNode ir compiledMethod. "generate method" homeMethodNode nodesDo: [:node | (node isBlock and: [node scope isInlined not and: [node ir compiledMethod = self]]) ifTrue: [ BlockNodeCache _ self -> node. ^ node] ]. self errorNodeNotFound! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:45'! decompile "Return the decompiled parse tree that represents self" ^ self decompileClass: nil selector: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 19:44'! decompileClass: aClass selector: selector "Return the decompiled parse tree that represents self" ^ self decompilerClass new decompile: selector in: aClass method: self! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'! decompilerClass ^Decompiler ! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 13:11'! isClosureCompiled "Return true if this method was compiled with the new closure compiler, Parser2 (compiled while Preference compileBlocksAsClosures was true). Return false if it was compiled with the old compiler." ^ self header < 0! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 2/9/2003 00:22'! methodNode "Return the parse tree that represents self" ^ self methodNodeDecompileClass: nil selector: nil! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 12/13/2003 18:30'! methodNodeDecompileClass: aClass selector: selector "Return the parse tree that represents self" | source | ^ (source _ self getSourceFromFile) ifNil: [self decompileClass: aClass selector: selector] ifNotNil: [self parserClass new parse: source class: (aClass ifNil: [self sourceClass])]! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:59'! methodNodeFormattedAndDecorated: decorate "Return the parse tree that represents self" ^ self methodNodeFormattedDecompileClass: nil selector: nil decorate: decorate! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'nk 2/20/2004 15:58'! methodNodeFormattedDecompileClass: aClass selector: selector decorate: decorated "Return the parse tree that represents self, using pretty-printed source text if possible." | source sClass node | source := self getSourceFromFile. sClass _ aClass ifNil: [self sourceClass]. source ifNil: [ ^self decompileClass: sClass selector: selector]. source _ sClass compilerClass new format: source in: sClass notifying: nil decorated: decorated. node _ sClass parserClass new parse: source class: sClass. node sourceText: source. ^node! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ar 6/28/2003 00:05'! parserClass ^Parser! ! !CompiledMethod methodsFor: 'decompiling' stamp: 'ajh 7/14/2001 12:34'! primitiveNode | primNode n | primNode _ PrimitiveNode new num: (n _ self primitive). (n = 117 or: [n = 120]) ifTrue: [ primNode spec: (self literalAt: 1)]. ^ primNode! ! !CompiledMethod methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 09:22'! hasBreakpoint ^BreakpointManager methodHasBreakpoint: self! ! !CompiledMethod methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:18'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^ CompiledMethodInspector! ! !CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0! My instances are methods suitable for interpretation by the virtual machine. This is the only class in the system whose instances intermix both indexable pointer fields and indexable integer fields. The current format of a CompiledMethod is as follows: header (4 bytes) literals (4 bytes each) bytecodes (variable) trailer (variable) The header is a 30-bit integer with the following format: (index 0) 9 bits: main part of primitive number (#primitive) (index 9) 8 bits: number of literals (#numLiterals) (index 17) 1 bit: whether a large frame size is needed (#frameSize) (index 18) 6 bits: number of temporary variables (#numTemps) (index 24) 4 bits: number of arguments to the method (#numArgs) (index 28) 1 bit: high-bit of primitive number (#primitive) (index 29) 1 bit: flag bit, ignored by the VM (#flag) The trailer has two variant formats. In the first variant, the last byte is at least 252 and the last four bytes represent a source pointer into one of the sources files (see #sourcePointer). In the second variant, the last byte is less than 252, and the last several bytes are a compressed version of the names of the method's temporary variables. The number of bytes used for this purpose is the value of the last byte in the method. ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 2/3/2003 21:16'! initialize "CompiledMethod initialize" "Initialize class variables specifying the size of the temporary frame needed to run instances of me." SmallFrame _ 16. "Context range for temps+stack" LargeFrame _ 56. self classPool at: #BlockNodeCache ifAbsentPut: [nil->nil].! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! smallFrameSize ^ SmallFrame! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ls 7/5/2003 13:49'! newBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag "Answer an instance of me. The header is specified by the message arguments. The remaining parts are not as yet determined." | largeBit primBits method flagBit | nTemps > 64 ifTrue: [^ self error: 'Cannot compile -- too many temporary variables']. largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0]. "For now the high bit of the primitive no. is in a high bit of the header" primBits _ (primitiveIndex bitAnd: 16r1FF) + ((primitiveIndex bitAnd: 16r200) bitShift: 19). flagBit := flag ifTrue: [ 1 ] ifFalse: [ 0 ]. method _ self newMethod: numberOfBytes + trailer size header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + (largeBit bitShift: 17) + (nLits bitShift: 9) + primBits + (flagBit bitShift: 29). "Copy the source code trailer to the end" 1 to: trailer size do: [:i | method at: method size - trailer size + i put: (trailer at: i)]. ^ method! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'ajh 3/9/2003 15:09'! primitive: primNum numArgs: numArgs numTemps: numTemps stackSize: stackSize literals: literals bytecodes: bytecodes trailer: trailerBytes "Create method with given attributes. numTemps includes numArgs. stackSize does not include numTemps." | compiledMethod | compiledMethod _ self newBytes: bytecodes size trailerBytes: trailerBytes nArgs: numArgs nTemps: numTemps nStack: stackSize nLits: literals size primitive: primNum. (WriteStream with: compiledMethod) position: compiledMethod initialPC - 1; nextPutAll: bytecodes. literals withIndexDo: [:obj :i | compiledMethod literalAt: i put: obj]. ^ compiledMethod! ! !CompiledMethodInspector methodsFor: 'accessing' stamp: 'ajh 1/18/2003 13:47'! fieldList | keys | keys _ OrderedCollection new. keys add: 'self'. keys add: 'all bytecodes'. keys add: 'header'. 1 to: object numLiterals do: [ :i | keys add: 'literal', i printString ]. object initialPC to: object size do: [ :i | keys add: i printString ]. ^ keys asArray ! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2003 00:17'! contentsIsString "Hacked so contents empty when deselected" ^ #(0 2 3) includes: selectionIndex! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 1/18/2003 13:56'! selection | bytecodeIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object ]. selectionIndex = 2 ifTrue: [^ object symbolic]. selectionIndex = 3 ifTrue: [^ object headerDescription]. selectionIndex <= (object numLiterals + 3) ifTrue: [ ^ object objectAt: selectionIndex - 2 ]. bytecodeIndex _ selectionIndex - object numLiterals - 3. ^ object at: object initialPC + bytecodeIndex - 1! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2001 11:56'! selectionUnmodifiable "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" ^ true! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:26'! returnPlusOne: anInteger ^anInteger + 1.! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 4/16/2003 15:25'! returnTrue ^true! ! !CompiledMethodTest methodsFor: 'testing - testing' stamp: 'md 4/16/2003 15:32'! testIsQuick | method | method := self class compiledMethodAt: #returnTrue. self assert: (method isQuick). method := self class compiledMethodAt: #returnPlusOne:. self deny: (method isQuick). ! ! !CompiledMethodTest methodsFor: 'testing - evaluating' stamp: 'md 4/16/2003 15:30'! testValueWithReceiverArguments | method value | method := self class compiledMethodAt: #returnTrue. value := method valueWithReceiver: nil arguments: #(). self assert: (value = true). method := self class compiledMethodAt: #returnPlusOne:. value := method valueWithReceiver: nil arguments: #(1). self assert: (value = 2). ! ! !CompiledMethodTest commentStamp: '' prior: 0! This is the unit test for the class CompiledMethod. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'! method: aCompiledMethod method _ aCompiledMethod! ! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'! node: aMethodNode node _ aMethodNode! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'! method ^ method! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! node ^ node! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! selector ^ self node selector! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! generateMethodFromNode: aMethodNode trailer: bytes ^ self method: (aMethodNode generate: bytes) node: aMethodNode.! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! method: aCompiledMethod node: aMethodNode ^ self new method: aCompiledMethod; node: aMethodNode.! ! !Compiler methodsFor: 'error handling' stamp: 'LC 1/6/2002 13:53'! notify: aString at: location "Refer to the comment in Object|notify:." requestor == nil ifTrue: [^SyntaxErrorNotification inClass: class withCode: (sourceStream contents copyReplaceFrom: location to: location - 1 with: aString) doitFlag: false] ifFalse: [^requestor notify: aString at: location in: sourceStream]! ! !Compiler methodsFor: 'public access' stamp: 'vb 8/13/2001 23:11'! compileNoPattern: textOrStream in: aClass context: aContext notifying: aRequestor ifFail: failBlock "Similar to #compile:in:notifying:ifFail:, but the compiled code is expected to be a do-it expression, with no message pattern." self from: textOrStream class: aClass context: aContext notifying: aRequestor. ^self translate: sourceStream noPattern: true ifFail: failBlock! ! !Compiler methodsFor: 'public access' stamp: 'sd 1/19/2004 20:58'! evaluate: aString in: aContext to: aReceiver "evaluate aString in the given context, and return the result. 2/2/96 sw" | result | result _ self evaluate: aString in: aContext to: aReceiver notifying: nil ifFail: [^ #failedDoit]. ^ result! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/19/2004 09:05'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! ! !Compiler methodsFor: 'public access' stamp: 'NS 1/28/2004 11:19'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method. This method is then installed in the receiver's class so that it can be invoked. In other words, if receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted. Finally, the compiled method is invoked from here as DoIt or (in the case of evaluation in aContext) DoItIn:. The method is subsequently removed from the class, but this will not get done if the invocation causes an error which is terminated. Such garbage can be removed by executing: Smalltalk allBehaviorsDo: [:cl | cl removeSelector: #DoIt; removeSelector: #DoItIn:]." | methodNode method value selector | class _ (aContext == nil ifTrue: [receiver] ifFalse: [aContext receiver]) class. self from: textOrStream class: class context: aContext notifying: aRequestor. methodNode _ self translate: sourceStream noPattern: true ifFail: [^failBlock value]. method _ methodNode generate: #(0 0 0 0). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. selector _ context isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. class addSelectorSilently: selector withMethod: method. value _ context isNil ifTrue: [receiver DoIt] ifFalse: [receiver DoItIn: context]. InMidstOfFileinNotification signal ifFalse: [class basicRemoveSelector: selector]. logFlag ifTrue: [SystemChangeNotifier uniqueInstance evaluated: sourceStream contents context: aContext]. ^ value.! ! !Compiler methodsFor: 'public access' stamp: 'sw 5/20/2001 10:01'! format: textOrStream in: aClass notifying: aRequestor contentsSymbol: aSymbol "Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, then decorate the resulting text with color and hypertext actions" | aNode | self from: textOrStream class: aClass context: nil notifying: aRequestor. aNode _ self format: sourceStream noPattern: false ifFail: [^ nil]. aSymbol == #colorPrint ifTrue: [^ aNode asColorizedSmalltalk80Text]. aSymbol == #altSyntax "Alan's current explorations for alternate syntax - 2000/2001" ifTrue: [^ aNode asAltSyntaxText]. ^ aNode decompileString! ! !Compiler methodsFor: 'public access' stamp: 'ajh 9/14/2002 18:47'! parse: textOrStream in: aClass notifying: req dialect: useDialect "Compile the argument, textOrStream, with respect to the class, aClass, and answer the MethodNode that is the root of the resulting parse tree. Notify the argument, req, if an error occurs. The failBlock is defaulted to an empty block." self from: textOrStream class: aClass context: nil notifying: req. ^ ((useDialect and: [RequestAlternateSyntaxSetting signal]) ifTrue: [self dialectParserClass] ifFalse: [self parserClass]) new parse: sourceStream class: class noPattern: false context: context notifying: requestor ifFail: []! ! !Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:19'! cacheDoItNode: boolean cacheDoItNode _ boolean! ! !Compiler methodsFor: 'private' stamp: 'ar 6/28/2003 00:05'! dialectParserClass ^DialectParser! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44'! format: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:44'! parserClass ^ parserClass! ! !Compiler methodsFor: 'private' stamp: 'ajh 9/19/2002 02:20'! parserClass: aParserClass parserClass _ aParserClass. cacheDoItNode _ true. ! ! !Compiler methodsFor: 'private' stamp: 'ajh 1/21/2003 12:45'! translate: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !Compiler class methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:56'! couldEvaluate: anObject "Answer true if anObject can be passed to my various #evaluate: methods." ^anObject isString or: [ anObject isText or: [ anObject isStream ]]! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:39'! new ^ super new parserClass: self parserClass! ! !Compiler class methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:42'! old ^ self new parserClass: Parser! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 10:07'! evaluate: textOrString "See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, a Syntax Error view is created rather than notifying any requestor. Compilation is carried out with respect to nil, i.e., no object, and the invocation is not logged." ^self evaluate: textOrString for: nil logged: false! ! !Compiler class methodsFor: 'evaluating' stamp: 'NS 1/19/2004 09:50'! evaluate: textOrString for: anObject notifying: aController logged: logFlag "Compile and execute the argument, textOrString with respect to the class of anObject. If a compilation error occurs, notify aController. If both compilation and execution are successful then, if logFlag is true, log (write) the text onto a system changes file so that it can be replayed if necessary." ^ self new evaluate: textOrString in: nil to: anObject notifying: aController ifFail: [^nil] logged: logFlag.! ! !Compiler class methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:07'! recompileAllFrom: firstName "Recompile all classes, starting with given name." Smalltalk forgetDoIts. Smalltalk allClassesDo: [:class | class name >= firstName ifTrue: [Transcript show: class name; cr. class compileAll]] "Compiler recompileAllFrom: 'AAABodyShop'." ! ! !Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'! imaginary ^ imaginary! ! !Complex methodsFor: 'accessing' stamp: 'mk 10/27/2003 17:39'! real ^ real! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/21/2004 11:25'! * anObject "Answer the result of multiplying the receiver by aNumber." | a b c d newReal newImaginary | anObject isComplex ifTrue: [a _ self real. b _ self imaginary. c _ anObject real. d _ anObject imaginary. newReal _ (a * c) - (b * d). newImaginary _ (a * d) + (b * c). ^ Complex real: newReal imaginary: newImaginary] ifFalse: [^ anObject adaptToComplex: self andSend: #*]! ! !Complex methodsFor: 'arithmetic' stamp: 'mk 1/18/2004 23:31'! + anObject "Answer the sum of the receiver and aNumber." | a b c d newReal newImaginary | anObject isComplex ifTrue: [a _ self real. b _ self imaginary. c _ anObject real. d _ anObject imaginary. newReal _ a + c. newImaginary _ b + d. ^ Complex real: newReal imaginary: newImaginary] ifFalse: [^ anObject adaptToComplex: self andSend: #+]! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'! - anObject "Answer the difference between the receiver and aNumber." | a b c d newReal newImaginary | anObject isComplex ifTrue: [a _ self real. b _ self imaginary. c _ anObject real. d _ anObject imaginary. newReal _ a - c. newImaginary _ b - d. ^ Complex real: newReal imaginary: newImaginary] ifFalse: [^ anObject adaptToComplex: self andSend: #-]! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:45'! / anObject "Answer the result of dividing receiver by aNumber" | a b c d newReal newImaginary | anObject isComplex ifTrue: [a _ self real. b _ self imaginary. c _ anObject real. d _ anObject imaginary. newReal _ ((a * c) + (b * d)) / ((c * c) + (d * d)). newImaginary _ ((b * c) - (a * d)) / ((c * c) + (d * d)). ^ Complex real: newReal imaginary: newImaginary]. ^ anObject adaptToComplex: self andSend: #/.! ! !Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 20:48'! abs "Answer the distance of the receiver from zero (0 + 0 i)." ^ ((real * real) + (imaginary * imaginary)) sqrt! ! !Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 22:08'! arg "Answer the argument of the receiver." self isZero ifTrue: [self error: 'zero has no argument.']. 0 < real ifTrue: [^ (imaginary / real) arcTan]. 0 = real ifTrue: [0 < imaginary ifTrue: [^ Float pi / 2] ifFalse: [^ (Float pi / 2) negated]]. real < 0 ifTrue: [0 <= imaginary ifTrue: [^ (imaginary / real) arcTan + Float pi] ifFalse: [^ (imaginary / real) arcTan - Float pi]]! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'! divideFastAndSecureBy: anObject "Answer the result of dividing receiver by aNumber" " Both operands are scaled to avoid arithmetic overflow. This algorithm works for a wide range of values, and it needs only three divisions. Note: #reciprocal uses #/ for devision " | r d newReal newImaginary | anObject isComplex ifTrue: [anObject real abs > anObject imaginary abs ifTrue: [r _ anObject imaginary / anObject real. d _ r*anObject imaginary + anObject real. newReal _ r*imaginary + real/d. newImaginary _ r negated * real + imaginary/d. ] ifFalse: [r _ anObject real / anObject imaginary. d := r*anObject real + anObject imaginary. newReal _ r*real + imaginary/d. newImaginary _ r*imaginary - real/d. ]. ^ Complex real: newReal imaginary: newImaginary]. ^ anObject adaptToComplex: self andSend: #/.! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:48'! divideSecureBy: anObject "Answer the result of dividing receiver by aNumber" " Both operands are scaled to avoid arithmetic overflow. This algorithm works for a wide range of values, but it requires six divisions. #divideFastAndSecureBy: is also quite good, but it uses only 3 divisions. Note: #reciprocal uses #/ for devision" | s ars ais brs bis newReal newImaginary | anObject isComplex ifTrue: [s := anObject real abs + anObject imaginary abs. ars := self real / s. ais := self imaginary / s. brs := anObject real / s. bis := anObject imaginary / s. s := brs squared + bis squared. newReal _ ars*brs + (ais*bis) /s. newImaginary _ ais*brs - (ars*bis)/s. ^ Complex real: newReal imaginary: newImaginary]. ^ anObject adaptToComplex: self andSend: #/.! ! !Complex methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 19:33'! negated "Answer a Number that is the negation of the receiver." ^0 - self! ! !Complex methodsFor: 'arithmetic' stamp: 'md 7/22/2004 11:47'! reciprocal "Answer 1 divided by the receiver. Create an error notification if the receiver is 0." self = 0 ifTrue: [^ (ZeroDivide dividend: self) signal] ifFalse: [^1 / self] ! ! !Complex methodsFor: 'comparing' stamp: 'mk 1/18/2004 23:37'! = anObject anObject isComplex ifTrue: [^ (real = anObject real) & (imaginary = anObject imaginary)] ifFalse: [^ anObject adaptToComplex: self andSend: #=]! ! !Complex methodsFor: 'comparing' stamp: 'mk 10/27/2003 20:35'! hash "Hash is reimplemented because = is implemented." ^ real hash bitXor: imaginary hash.! ! !Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 21:51'! adaptToCollection: rcvr andSend: selector "If I am involved in arithmetic with a Collection, return a Collection of the results of each element combined with me in that expression." ^ rcvr collect: [:element | element perform: selector with: self]! ! !Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'! adaptToFloat: rcvr andSend: selector "If I am involved in arithmetic with a Float, convert it to a Complex number." ^ rcvr asComplex perform: selector with: self! ! !Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:32'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert it to a Complex number." ^ rcvr asComplex perform: selector with: self! ! !Complex methodsFor: 'converting' stamp: 'mk 10/27/2003 18:31'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Complex number." ^ rcvr asComplex perform: selector with: self! ! !Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! cos "Answer receiver's cosine." | iself | iself _ 1 i * self. ^ (iself exp + iself negated exp) / 2! ! !Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:34'! cosh "Answer receiver's hyperbolic cosine." ^ (self exp + self negated exp) / 2! ! !Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! exp "Answer the exponential of the receiver." ^ real exp * (imaginary cos + (1 i * imaginary sin))! ! !Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! ln "Answer the natural log of the receiver." ^ self arg ln + (1 i * self arg)! ! !Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:05'! log: aNumber "Answer the log base aNumber of the receiver." ^self ln / aNumber ln! ! !Complex methodsFor: 'mathematical functions' stamp: 'md 7/16/2004 16:16'! sin "Answer receiver's sine." | iself | iself _ 1 i * self. ^ (iself exp - iself negated exp) / 2 i! ! !Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 21:33'! sinh "Answer receiver's hyperbolic sine." ^ (self exp - self negated exp) / 2! ! !Complex methodsFor: 'mathematical functions' stamp: 'md 7/20/2004 12:02'! squared "Answer the receiver multipled by itself." ^self * self! ! !Complex methodsFor: 'mathematical functions' stamp: 'mk 10/27/2003 22:04'! tan "Answer receivers tangent." ^ self sin / self cos! ! !Complex methodsFor: 'printing' stamp: 'mk 10/27/2003 18:02'! printOn: aStream real printOn: aStream. aStream nextPut: Character space. 0 <= imaginary ifTrue: [aStream nextPut: $+] ifFalse: [aStream nextPut: $-]. aStream nextPut: Character space. imaginary abs printOn: aStream. aStream nextPut: Character space. aStream nextPut: $i ! ! !Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'! imaginary: aNumber imaginary _ aNumber.! ! !Complex methodsFor: 'private' stamp: 'mk 10/27/2003 17:26'! real: aNumber real _ aNumber.! ! !Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'! isComplex ^ true! ! !Complex methodsFor: 'testing' stamp: 'mk 10/27/2003 20:06'! isZero ^ self = 0! ! !Complex commentStamp: 'mk 10/31/2003 22:19' prior: 0! I represent a complex number. real -- real part of the complex number imaginary -- imaginary part of the complex number Complex number constructors: 5 i 6 + 7 i. 5.6 - 8 i. Complex real: 10 imaginary: 5. Complex abs: 5 arg: (Float pi / 4) Arithmetic operation with other complex or non-complex numbers work. (5 - 6 i) + (-5 + 8 i). "Arithmetic between two complex numbers." 5 * (5 - 6 i). "Arithmetic between a non-complex and a complex number." It is also possible to perform arithmetic operations between a complex number and a array of (complex) numbers: 2 * {1 + 2i. 3 + 4i. 5 + 6i} 5 + 5i * {1 + 2i. 3. 5 + 6i} It behaves analogously as it is with normal numbers and an array. NOTE: Although Complex something similiar to the Smalltalk's Number class, it would not be a good idea to make a Complex to be a subclass of a Number because: - Number is subclass of Magnitude and Complex is certainly not a magnitude. Complex does not behave very well as a Magnitude. Operations such as < > <= >= do not have sense in case of complex numbers. - Methods in the following Number methods' categories do not have sense for a Complex numbers trucation and round off testing intervals comparing - However the following Number methods' categories do have sense for a Complex number arithmetic (with the exception of operation // \\ quo: rem: mathematical functions Thus Complex is somewhat similar to a Number but it is not a subclass of it. Some operations we would like to inherit (e.g. #abs, #negated, #reciprocal) but some of the Number operation do not have sens to inherit or to overload. Classes are not always neat mechanism. !!!!!! We had to COPY the implementation of the abs negated reciprocal log: isZero reciprocal ... methods from the Number class to the Complex class. Awful solution. Now I begin to appreciate the Self. Missing methods String | converting | asComplex Complex | mathematical functions | arcSin Complex | mathematical functions | arcCos Complex | mathematical functions | arcTan! !Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 21:03'! abs: aNumber1 arg: aNumber2 | real imaginary | real _ aNumber1 * aNumber2 cos. imaginary _ aNumber1 * aNumber2 sin. ^ real + imaginary i! ! !Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:28'! new ^ self real: 0 imaginary: 0! ! !Complex class methodsFor: 'instance creation' stamp: 'mk 10/27/2003 17:27'! real: aNumber1 imaginary: aNumber2 | newComplex | newComplex _ super new. newComplex real: aNumber1; imaginary: aNumber2. ^ newComplex! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:13'! colors ^colors ifNil:[colors _ self computeColors].! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style ^style! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style: newStyle style == newStyle ifTrue:[^self]. style _ newStyle. self releaseCachedState.! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'! widthForRounding ^0! ! !ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph raisedColor].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'aoy 2/17/2003 01:08'! drawLineFrom: startPoint to: stopPoint on: aCanvas "Here we're using the balloon engine since this is much faster than BitBlt w/ brushes." | delta length dir cos sin tfm w h w1 w2 h1 h2 fill | width isPoint ifTrue: [w := width x. h := width y] ifFalse: [w := h := width]. w1 := w // 2. w2 := w - w1. h1 := h // 2. h2 := h - h1. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" delta := stopPoint - startPoint. length := delta r. dir := length > 1.0e-10 ifTrue: [delta / length] ifFalse: [ 1 @ 0]. cos := dir dotProduct: 1 @ 0. sin := dir crossProduct: 1 @ 0. tfm := (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. "Now get the fill style appropriate for the given direction" fill := self fillStyleForDirection: dir. "And draw..." aCanvas asBalloonCanvas transformBy: tfm during: [:cc | cc drawPolygon: { (0 - w1) @ (0 - h1). "top left" (length + w2) @ (0 - h1). "top right" (length + w2) @ h2. "bottom right" (0 - w1) @ h2 "bottom left"} fillStyle: fill]! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 11/26/2001 15:10'! drawPolyPatchFrom: startPoint to: stopPoint on: aCanvas usingEnds: endsArray | cos sin tfm fill dir fsOrigin fsDirection points x y | dir _ (stopPoint - startPoint) normalized. "Compute the rotational transform from (0@0) -> (1@0) to startPoint -> stopPoint" cos _ dir dotProduct: (1@0). sin _ dir crossProduct: (1@0). "Now get the fill style appropriate for the given direction" fill _ self fillStyleForDirection: dir. false ifTrue:[ "Transform the fill appropriately" fill _ fill clone. "Note: Code below is inlined from tfm transformPoint:/transformDirection:" x _ fill origin x. y _ fill origin y. fsOrigin _ ((x * cos) + (y * sin) + startPoint x) @ ((y * cos) - (x * sin) + startPoint y). x _ fill direction x. y _ fill direction y. fsDirection _ ((x * cos) + (y * sin)) @ ((y * cos) - (x * sin)). fill origin: fsOrigin; direction: fsDirection rounded; "NOTE: This is a bug in the balloon engine!!!!!!" normal: nil. aCanvas asBalloonCanvas drawPolygon: endsArray fillStyle: fill. ] ifFalse:[ "Transform the points rather than the fills" tfm _ (MatrixTransform2x3 new) a11: cos; a12: sin; a21: sin negated; a22: cos. "Install the start point offset" tfm offset: startPoint. points _ endsArray collect:[:pt| tfm invertPoint: pt]. aCanvas asBalloonCanvas transformBy: tfm during:[:cc| cc drawPolygon: points fillStyle: fill. ]. ].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:51'! framePolygon2: vertices on: aCanvas | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends | balloon _ aCanvas asBalloonCanvas. balloon == aCanvas ifFalse:[balloon deferred: true]. ends _ Array new: 4. w _ width * 0.5. pointA _ nil. 1 to: vertices size do:[:i| p1 _ vertices atWrap: i. p2 _ vertices atWrap: i+1. p3 _ vertices atWrap: i+2. p4 _ vertices atWrap: i+3. dir1 _ p2 - p1. dir2 _ p3 - p2. dir3 _ p4 - p3. i = 1 ifTrue:[ "Compute the merge points of p1->p2 with p2->p3" cross1 _ dir2 crossProduct: dir1. nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w). nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated]. point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y). point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y). point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). pointB _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. pointB ifNotNil:[ (pointB x - p2 x) abs + (pointB y - p2 y) abs > (4*w) ifTrue:[pointA _ pointB _ nil]. ]. ]. "Compute the merge points of p2->p3 with p3->p4" cross2 _ dir3 crossProduct: dir2. nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y). pointC _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y). pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. pointD ifNotNil:[ (pointD x - p3 x) abs + (pointD y - p3 y) abs > (4*w) ifTrue:[pointC _ pointD _ nil]. ]. cross1 * cross2 < 0.0 ifTrue:[ point1 _ pointA. pointA _ pointB. pointB _ point1. cross1 _ 0.0 - cross1]. ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointD; at: 4 put: pointC. pointA ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). ends at: 1 put: point2]. pointB ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). ends at: 2 put: point2]. pointC ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p3 x + nrm2 x) @ (p3 y + nrm2 y). ends at: 4 put: point2]. pointD ifNil:["degenerate and slow" nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated]. point2 _ (p3 x - nrm2 x) @ (p3 y - nrm2 y). ends at: 3 put: point2]. self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. pointA _ pointC. pointB _ pointD. cross1 _ cross2. ]. balloon == aCanvas ifFalse:[balloon flush].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 9/4/2001 19:50'! framePolygon: vertices on: aCanvas | dir1 dir2 dir3 nrm1 nrm2 nrm3 point1 point2 point3 cross1 cross2 pointA pointB pointC pointD w p1 p2 p3 p4 balloon ends pointE pointF | balloon _ aCanvas asBalloonCanvas. balloon == aCanvas ifFalse:[balloon deferred: true]. ends _ Array new: 6. w _ width * 0.5. pointA _ nil. 1 to: vertices size do:[:i| p1 _ vertices atWrap: i. p2 _ vertices atWrap: i+1. p3 _ vertices atWrap: i+2. p4 _ vertices atWrap: i+3. dir1 _ p2 - p1. dir2 _ p3 - p2. dir3 _ p4 - p3. (i = 1 | true) ifTrue:[ "Compute the merge points of p1->p2 with p2->p3" cross1 _ dir2 crossProduct: dir1. nrm1 _ dir1 normalized. nrm1 _ (nrm1 y * w) @ (0 - nrm1 x * w). nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). cross1 < 0 ifTrue:[nrm1 _ nrm1 negated. nrm2 _ nrm2 negated]. point1 _ (p1 x + nrm1 x) @ (p1 y + nrm1 y). point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). pointA _ self intersectFrom: point1 with: dir1 to: point2 with: dir2. point1 _ (p1 x - nrm1 x) @ (p1 y - nrm1 y). point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). pointB _ point1 + dir1 + point2 * 0.5. pointB _ p2 + ((pointB - p2) normalized * w). pointC _ point2. ]. "Compute the merge points of p2->p3 with p3->p4" cross2 _ dir3 crossProduct: dir2. nrm2 _ dir2 normalized. nrm2 _ (nrm2 y * w) @ (0 - nrm2 x * w). nrm3 _ dir3 normalized. nrm3 _ (nrm3 y * w) @ (0 - nrm3 x * w). cross2 < 0 ifTrue:[nrm2 _ nrm2 negated. nrm3 _ nrm3 negated]. point2 _ (p2 x + nrm2 x) @ (p2 y + nrm2 y). point3 _ (p3 x + nrm3 x) @ (p3 y + nrm3 y). pointD _ self intersectFrom: point2 with: dir2 to: point3 with: dir3. point2 _ (p2 x - nrm2 x) @ (p2 y - nrm2 y). point3 _ (p3 x - nrm3 x) @ (p3 y - nrm3 y). pointF _ point2 + dir2. pointE _ pointF + point3 * 0.5. pointE _ p3 + ((pointE - p3) normalized * w). cross1 * cross2 < 0.0 ifTrue:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointD; at: 5 put: pointE; at: 6 put: pointF. ] ifFalse:[ ends at: 1 put: pointA; at: 2 put: pointB; at: 3 put: pointC; at: 4 put: pointF; at: 5 put: pointE; at: 6 put: pointD. ]. self drawPolyPatchFrom: p2 to: p3 on: balloon usingEnds: ends. pointA _ pointD. pointB _ pointE. pointC _ pointF. cross1 _ cross2. ]. balloon == aCanvas ifFalse:[balloon flush].! ! !ComplexBorder methodsFor: 'drawing' stamp: 'ar 8/26/2001 19:01'! frameRectangle: aRectangle on: aCanvas "Note: This uses BitBlt since it's roughly a factor of two faster for rectangles" | w h r | self colors ifNil:[^super frameRectangle: aRectangle on: aCanvas]. w _ self width. w isPoint ifTrue:[h _ w y. w _ w x] ifFalse:[h _ w]. 1 to: h do:[:i| "top/bottom" r _ (aRectangle topLeft + (i-1)) extent: (aRectangle width - (i-1*2))@1. "top" aCanvas fillRectangle: r color: (colors at: i). r _ (aRectangle bottomLeft + (i @ (0-i))) extent: (aRectangle width - (i-1*2) - 1)@1. "bottom" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ]. 1 to: w do:[:i| "left/right" r _ (aRectangle topLeft + (i-1)) extent: 1@(aRectangle height - (i-1*2)). "left" aCanvas fillRectangle: r color: (colors at: i). r _ aRectangle topRight + ((0-i)@i) extent: 1@(aRectangle height - (i-1*2) - 1). "right" aCanvas fillRectangle: r color: (colors at: colors size - i + 1). ].! ! !ComplexBorder methodsFor: 'initialize' stamp: 'ar 11/26/2001 14:43'! releaseCachedState colors _ nil. lineStyles _ nil.! ! !ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^true! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:02'! colorsForDirection: direction "Return an array of colors describing the receiver in the given direction" | colorArray dT cc | cc := self colors. direction x * direction y <= 0 ifTrue: ["within up->right or down->left transition; no color blend needed" colorArray := (direction x > 0 or: [direction y < 0]) ifTrue: ["up->right" cc copyFrom: 1 to: width] ifFalse: ["down->left" "colors are stored in reverse direction when following a line" (cc copyFrom: width + 1 to: cc size) reversed]] ifFalse: ["right->down or left->up transition; need color blend" colorArray := Array new: width. dT := direction x asFloat / (direction x + direction y). (direction x > 0 or: [direction y >= 0]) ifTrue: ["top-right" 1 to: width do: [:i | colorArray at: i put: ((cc at: i) mixed: dT with: (cc at: cc size - i + 1))]] ifFalse: ["bottom-left" 1 to: width do: [:i | colorArray at: i put: ((cc at: cc size - i + 1) mixed: dT with: (cc at: i))]]]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:16'! computeAltFramedColors | base light dark w hw colorArray param | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray _ Array new: w. hw _ w // 2. "brighten" 0 to: hw-1 do:[:i| param _ 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: dark). "brighten" colorArray at: w-i put: (base mixed: param with: light). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:03'! computeAltInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := false ifTrue: ["whats this ???!! false ifTrue:[]" 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:05'! computeAltRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | "again !! false ifTrue:[] ?!!" param := false ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 11/26/2001 15:00'! computeColors width = 0 ifTrue:[^colors _ #()]. style == #complexFramed ifTrue:[^self computeFramedColors]. style == #complexAltFramed ifTrue:[^self computeAltFramedColors]. style == #complexRaised ifTrue:[^self computeRaisedColors]. style == #complexAltRaised ifTrue:[^self computeAltRaisedColors]. style == #complexInset ifTrue:[^self computeInsetColors]. style == #complexAltInset ifTrue:[^self computeAltInsetColors]. self error:'Unknown border style: ', style printString.! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/25/2001 16:35'! computeFramedColors | base light dark w hw colorArray param | base _ self color asColor. light _ Color white. dark _ Color black. w _ self width isPoint ifTrue:[self width x max: self width y] ifFalse:[self width]. w _ w asInteger. w = 1 ifTrue:[^{base mixed: 0.5 with: light. base mixed: 0.5 with: dark}]. colorArray _ Array new: w. hw _ w // 2. "brighten" 0 to: hw-1 do:[:i| param _ 0.5 + (i asFloat / hw * 0.5). colorArray at: i+1 put: (base mixed: param with: light). "brighten" colorArray at: w-i put: (base mixed: param with: dark). "darken" ]. w odd ifTrue:[colorArray at: hw+1 put: base]. ^colorArray, colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:06'! computeInsetColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [ 0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: dark). "darken" colorArray at: colorArray size - i put: (base mixed: param with: light) "brighten"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'aoy 2/17/2003 01:07'! computeRaisedColors | base light dark w colorArray param hw | base := self color asColor. light := Color white. dark := Color black. w := self width isPoint ifTrue: [self width x max: self width y] ifFalse: [self width]. w := w asInteger. colorArray := Array new: w * 2. hw := 0.5 / w. 0 to: w - 1 do: [:i | param := true ifTrue: [0.5 + (hw * i)] ifFalse: [0.5 + (hw * (w - i))]. colorArray at: i + 1 put: (base mixed: param with: light). "brighten" colorArray at: colorArray size - i put: (base mixed: param with: dark) "darken"]. ^colorArray! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 9/4/2001 19:51'! fillStyleForDirection: direction "Fill the given form describing the receiver's look at a particular direction" | index fill dir | index _ direction degrees truncated // 10 + 1. lineStyles ifNotNil:[ fill _ lineStyles at: index. fill ifNotNil:[^fill]. ]. dir _ Point r: 1.0 degrees: index - 1 * 10 + 5. fill _ GradientFillStyle colors: (self colorsForDirection: dir). fill direction: 0 @ width asPoint y; radial: false. fill origin: ((width asPoint x // 2) @ (width asPoint y // 2)) negated. fill pixelRamp: (fill computePixelRampOfSize: 16). fill isTranslucent. "precompute" lineStyles ifNil:[lineStyles _ Array new: 37]. lineStyles at: index put: fill. ^fill! ! !ComplexBorder methodsFor: 'private' stamp: 'ar 8/26/2001 23:39'! intersectFrom: startPt with: startDir to: endPt with: endDir "Compute the intersection of two lines. Return nil if either * the intersection does not exist, or * the intersection is 'before' startPt, or * the intersection is 'after' endPt " | det deltaPt alpha beta | det _ (startDir x * endDir y) - (startDir y * endDir x). det = 0.0 ifTrue:[^nil]. "There's no solution for it" deltaPt _ endPt - startPt. alpha _ (deltaPt x * endDir y) - (deltaPt y * endDir x). beta _ (deltaPt x * startDir y) - (deltaPt y * startDir x). alpha _ alpha / det. beta _ beta / det. alpha < 0 ifTrue:[^nil]. beta > 1.0 ifTrue:[^nil]. "And compute intersection" ^(startPt x + (alpha * startDir x)) @ (startPt y + (alpha * startDir y))! ! !ComplexBorder commentStamp: 'kfr 10/27/2003 10:18' prior: 0! see BorderedMorph. poly _ polygon250 baseColor _ Color blue twiceLighter. border _ (ComplexBorder framed: 10) baseColor: poly color. border frameRectangle: ((100@100 extent: 200@200) insetBy: -5) on: Display getCanvas. baseColor _ Color red twiceLighter. border _ (ComplexBorder framed: 10) baseColor: baseColor. border drawPolygon: {100@100. 300@100. 300@300. 100@300} on: Display getCanvas. border drawPolyPatchFrom: 100@200 via: 100@100 via: 200@100 to: 200@200 on: Display getCanvas. border drawPolyPatchFrom: 100@100 via: 200@100 via: 200@200 to: 100@200 on: Display getCanvas. border drawPolyPatchFrom: 200@100 via: 200@200 via: 100@200 to: 100@100 on: Display getCanvas. border drawPolyPatchFrom: 200@200 via: 100@200 via: 100@100 to: 200@100 on: Display getCanvas. border _ (ComplexBorder raised: 10) baseColor: poly color. border drawPolygon: poly getVertices on: Display getCanvas 360 / 16.0 22.5 points _ (0 to: 15) collect:[:i| (Point r: 100 degrees: i*22.5) + 200]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. border drawPolygon: points on: Display getCanvas. -1 to: points size + 1 do:[:i| border drawPolyPatchFrom: (points atWrap: i) via: (points atWrap: i+1) via: (points atWrap: i+2) to: (points atWrap: i+3) on: Display getCanvas. ]. Display getCanvas fillOval: (100@100 extent: 200@200) color: baseColor. 0 to: 36 do:[:i| border drawLineFrom: (Point r: 100 degrees: i*10) + 200 to: (Point r: 100 degrees: i+1*10) + 200 on: Display getCanvas. ]. drawPolygon: Point r: 1.0 degrees: 10 MessageTally spyOn:[ Display deferUpdates: true. t1 _ [1 to: 1000 do:[:i| border drawLineFrom: (100@100) to: (300@100) on: Display getCanvas. border drawLineFrom: (300@100) to: (300@300) on: Display getCanvas. border drawLineFrom: (300@300) to: (100@300) on: Display getCanvas. border drawLineFrom: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. MessageTally spyOn:[ Display deferUpdates: true. t2 _ [1 to: 1000 do:[:i| border drawLine2From: (100@100) to: (300@100) on: Display getCanvas. border drawLine2From: (300@100) to: (300@300) on: Display getCanvas. border drawLine2From: (300@300) to: (100@300) on: Display getCanvas. border drawLine2From: (100@300) to: (100@100) on: Display getCanvas]] timeToRun. Display deferUpdates: false. ]. ! !ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'! style: aSymbol ^self new style: aSymbol! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'nk 8/18/2004 16:43'! addProgressDecoration: extraParam | f m | targetMorph ifNil: [^self]. (extraParam isForm) ifTrue: [targetMorph submorphsDo: [:mm | (mm isSketchMorph) ifTrue: [mm delete]]. f := Form extent: extraParam extent depth: extraParam depth. extraParam displayOn: f. m := SketchMorph withForm: f. m align: m fullBounds leftCenter with: targetMorph fullBounds leftCenter + (2 @ 0). targetMorph addMorph: m. ^self]. (extraParam isString) ifTrue: [targetMorph submorphsDo: [:mm | (mm isKindOf: StringMorph) ifTrue: [mm delete]]. m := StringMorph contents: extraParam translated. m align: m fullBounds bottomCenter + (0 @ 8) with: targetMorph bounds bottomCenter. targetMorph addMorph: m. ^self]! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! backgroundWorldDisplay | f | self flag: #bob. "really need a better way to do this" "World displayWorldSafely." "ugliness to try to track down a possible error" [World displayWorld] ifError: [ :a :b | stageCompleted _ 999. f _ FileDirectory default fileNamed: 'bob.errors'. f nextPutAll: a printString,' ',b printString; cr; cr. f nextPutAll: 'worlds equal ',(formerWorld == World) printString; cr; cr. f nextPutAll: thisContext longStack; cr; cr. f nextPutAll: formerProcess suspendedContext longStack; cr; cr. f close. Beeper beep. ]. ! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'ar 7/8/2001 17:05'! forkProgressWatcher | killTarget | [ [stageCompleted < 999 and: [formerProject == Project current and: [formerWorld == World and: [translucentMorph world notNil and: [formerProcess suspendedContext notNil and: [Project uiProcess == formerProcess]]]]]] whileTrue: [ translucentMorph setProperty: #revealTimes toValue: {(Time millisecondClockValue - start max: 1). (estimate * newRatio max: 1)}. translucentMorph changed. translucentMorph owner addMorphInLayer: translucentMorph. (Time millisecondClockValue - WorldState lastCycleTime) abs > 500 ifTrue: [ self backgroundWorldDisplay ]. (Delay forMilliseconds: 100) wait. ]. translucentMorph removeProperty: #revealTimes. self loadingHistoryAt: 'total' add: (Time millisecondClockValue - start max: 1). killTarget _ targetMorph ifNotNil: [ targetMorph valueOfProperty: #deleteOnProgressCompletion ]. formerWorld == World ifTrue: [ translucentMorph delete. killTarget ifNotNil: [killTarget delete]. ] ifFalse: [ translucentMorph privateDeleteWithAbsolutelyNoSideEffects. killTarget ifNotNil: [killTarget privateDeleteWithAbsolutelyNoSideEffects]. ]. ] forkAt: Processor lowIOPriority.! ! !ComplexProgressIndicator methodsFor: 'as yet unclassified' stamp: 'mir 3/9/2004 16:27'! withProgressDo: aBlock | safetyFactor totals trialRect delta stageCompletedString targetOwner | Smalltalk isMorphic ifFalse: [^aBlock value]. formerProject _ Project current. formerWorld _ World. formerProcess _ Processor activeProcess. targetMorph ifNil: [targetMorph _ ProgressTargetRequestNotification signal]. targetMorph ifNil: [ trialRect _ Rectangle center: Sensor cursorPoint extent: 80@80. delta _ trialRect amountToTranslateWithin: formerWorld bounds. trialRect _ trialRect translateBy: delta. translucentMorph _ TranslucentProgessMorph new opaqueBackgroundColor: Color white; bounds: trialRect; openInWorld: formerWorld. ] ifNotNil: [ targetOwner := targetMorph owner. translucentMorph _ TranslucentProgessMorph new setProperty: #morphicLayerNumber toValue: targetMorph morphicLayerNumber - 0.1; bounds: targetMorph boundsInWorld; openInWorld: targetMorph world. ]. stageCompleted _ 0. safetyFactor _ 1.1. "better to guess high than low" translucentMorph setProperty: #progressStageNumber toValue: 1. translucentMorph hide. targetOwner ifNotNil: [targetOwner hide]. totals _ self loadingHistoryDataForKey: 'total'. newRatio _ 1.0. estimate _ totals size < 2 ifTrue: [ 15000 "be a pessimist" ] ifFalse: [ (totals sum - totals max) / (totals size - 1 max: 1) * safetyFactor. ]. start _ Time millisecondClockValue. self forkProgressWatcher. [ aBlock on: ProgressInitiationException do: [ :ex | ex sendNotificationsTo: [ :min :max :curr | "ignore this as it is inaccurate" ]. ]. ] on: ProgressNotification do: [ :note | translucentMorph show. targetOwner ifNotNil: [targetOwner show]. note extraParam ifNotNil:[self addProgressDecoration: note extraParam]. stageCompletedString _ (note messageText findTokens: ' ') first. stageCompleted _ (stageCompletedString copyUpTo: $:) asNumber. cumulativeStageTime _ Time millisecondClockValue - start max: 1. prevData _ self loadingHistoryDataForKey: stageCompletedString. prevData isEmpty ifFalse: [ newRatio _ (cumulativeStageTime / (prevData average max: 1)) asFloat. ]. self loadingHistoryAt: stageCompletedString add: cumulativeStageTime. translucentMorph setProperty: #progressStageNumber toValue: stageCompleted + 1. note resume. ]. stageCompleted _ 999. "we may or may not get here" ! ! !ComplexProgressIndicator class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! historyReport " ComplexProgressIndicator historyReport " | answer data | History ifNil: [^Beeper beep]. answer _ String streamContents: [ :strm | (History keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :k | strm nextPutAll: k printString; cr. data _ History at: k. (data keys asSortedCollection: [ :a :b | a asString <= b asString]) do: [ :dataKey | strm tab; nextPutAll: dataKey printString,' ', (data at: dataKey) asArray printString; cr. ]. strm cr. ]. ]. StringHolder new contents: answer contents; openLabel: 'Progress History'! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:00'! testAbs "self run: #testAbs" "self debug: #testAbs" | c | c := (6 - 6 i). self assert: c abs = 72 sqrt. ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 13:59'! testAdding "self run: #testAdding" | c | c := (5 - 6 i) + (-5 + 8 i). "Complex with Complex" self assert: (c = (0 + 2 i)).! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:02'! testArg "self run: #testArg" "self debug: #testArg" | c | c := (0 + 5 i) . self assert: c arg = (Float pi/ 2). ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:13'! testComplexCollection "self run: #testComplexCollection" "self debug: #testComplexCollection" | array array2 | array := Array with: 1 + 2i with: 3 + 4i with: 5 + 6i. array2 := 2 * array. array with: array2 do: [:one :two | self assert: (2 * one) = two ] ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:16'! testConversion "self run: #testConversion" "self debug: #testConversion" self assert: ((1 + 2i) + 1) = (2 + 2 i). self assert: (1 + (1 + 2i)) = (2 + 2 i). self assert: ((1 + 2i) + 1.0) = (2.0 + 2 i). self assert: (1.0 + (1 + 2i)) = (2.0 + 2 i). self assert: ((1 + 2i) + (2/3)) = ((5/3) + 2 i ). self assert: ((2/3) + (1 + 2i)) = ((5/3) + 2 i )! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 13:59'! testCreation "self run: #testCreation" | c | c := 5 i. self assert: (c real = 0). self assert: (c imaginary = 5). c := 6 + 7 i. self assert: (c real = 6). self assert: ( c imaginary = 7). c := 5.6 - 8 i. self assert: (c real = 5.6). self assert: (c imaginary = -8). c := Complex real: 10 imaginary: 5. self assert: (c real = 10). self assert: (c imaginary = 5). c := Complex abs: 5 arg: (Float pi/2). self assert: (c real rounded = 0). self assert: (c imaginary = 5). ! ! !ComplexTest methodsFor: 'testing' stamp: 'md 7/22/2004 11:42'! testDivision1 "self run: #testDivision1" "self debug: #testDivision1" | c1 c2 quotient | c1 := 2.0e252 + 3.0e70 i. c2 := c1. quotient := c1 / c2. self deny: (quotient - 1) isZero. "This test fails due to the wonders of floating point arithmetic. Please have a look at Complex>>divideSecureBy: and #divideFastAndSecureBy: how this can be avoided." ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:10'! testEquality "self run: #testEquality" "self debug: #testEquality" self assert: 0i = 0. self assert: (2 - 5i) = ((1 -4 i) + (1 - 1i)). self assert: 0i isZero. self deny: (1 + 3 i) = 1. self deny: (1 + 3 i) = (1 + 2i).! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:03'! testNegated "self run: #testNegated" "self debug: #testNegated" | c | c := (2 + 5 i) . self assert: c negated = (-2 - 5i). ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:05'! testReciprocal "self run: #testReciprocal" "self debug: #testReciprocal" | c | c := (2 + 5 i). self assert: c reciprocal = ((2/29) - (5/29)i). ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 14:07'! testReciprocalError "self run: #testReciprocalError" "self debug: #testReciprocalError" | c | c := (0 i). self should: [c reciprocal] raise: ZeroDivide ! ! !ComplexTest methodsFor: 'testing' stamp: 'md 7/22/2004 11:44'! testSecureDivision1 "self run: #testSecureDivision1" "self debug: #testSecureDivision1" | c1 c2 quotient | c1 := 2.0e252 + 3.0e70 i. c2 := c1. quotient := c1 divideSecureBy: c2. self assert: (quotient - 1) isZero. ! ! !ComplexTest methodsFor: 'testing' stamp: 'md 7/22/2004 11:44'! testSecureDivision2 "self run: #testSecureDivision2" "self debug: #testSecureDivision2" | c1 c2 quotient | c1 := 2.0e252 + 3.0e70 i. c2 := c1. quotient := c1 divideFastAndSecureBy: c2. self assert: (quotient - 1) isZero. ! ! !ComplexTest methodsFor: 'testing' stamp: 'sd 7/17/2004 13:24'! testSquared "self run: #testSquared" "self debug: #testSquared" | c c2 | c := (6 - 6 i). c2 := (c squared). self assert: c2 imaginary = -72. self assert: c2 real = 0.! ! !Component methodsFor: 'variables' stamp: 'gm 3/2/2003 18:35'! addVariableNamed: varName "Adjust name if necessary and add it" | otherNames i partName | otherNames := self class allInstVarNames. i := nil. [partName := i isNil ifTrue: [varName] ifFalse: [varName , i printString]. otherNames includes: partName] whileTrue: [i := i isNil ifTrue: [1] ifFalse: [i + 1]]. self class addInstVarName: partName. "Now compile read method and write-with-change method" self class compile: (String streamContents: [:s | s nextPutAll: partName; cr; tab; nextPutAll: '^' , partName]) classified: 'view access' notifying: nil. self class compile: (String streamContents: [:s | s nextPutAll: partName , 'Set: newValue'; cr; tab; nextPutAll: partName , ' _ newValue.'; cr; tab; nextPutAll: 'self changed: #' , partName , '.'; cr; tab; nextPutAll: '^ true' "for components that expect a boolean for accept"]) classified: 'view access' notifying: nil. ^Array with: partName asSymbol with: (partName , 'Set:') asSymbol! ! !ComponentLayout methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:17'! addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. menu addLine. menu add: 'inspect model in morphic' translated action: #inspectModelInMorphic! ! !ComponentLayout methodsFor: 'model' stamp: 'dgd 2/21/2003 23:06'! createCustomModel "Create a model object for this world if it does not yet have one. The default model for an EditView is a Component." model isNil ifFalse: [^self]. "already has a model" model := Component newSubclass new! ! !ComponentLayout methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 19:06'! allKnownNames ^super allKnownNames , (self submorphs collect: [:m | m knownName] thenSelect: [:m | m notNil])! ! !ComponentLikeModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:01'! choosePartName "When I am renamed, get a slot, make default methods, move any existing methods." | old | (self pasteUpMorph model isKindOf: Component) ifTrue: [self knownName ifNil: [^self nameMeIn: self pasteUpMorph] ifNotNil: [^self renameMe]]. old := slotName. super choosePartName. slotName ifNil: [^self]. "user chose bad slot name" self model: self world model slotName: slotName. old isNil ifTrue: [self compilePropagationMethods] ifFalse: [self copySlotMethodsFrom: old] "old ones not erased!!"! ! !ComponentLikeModel methodsFor: 'submorphs-add/remove' stamp: 'gm 2/22/2003 13:14'! delete "Delete the receiver. Possibly put up confirming dialog. Abort if user changes mind" (model isKindOf: Component) ifTrue: [^self deleteComponent]. (model isMorphicModel) ifFalse: [^super delete]. slotName ifNotNil: [(PopUpMenu confirm: 'Shall I remove the slot ' , slotName , ' along with all associated methods?') ifTrue: [(model class selectors select: [:s | s beginsWith: slotName]) do: [:s | model class removeSelector: s]. (model class instVarNames includes: slotName) ifTrue: [model class removeInstVarName: slotName]] ifFalse: [(PopUpMenu confirm: '...but should I at least dismiss this morph? [choose no to leave everything unchanged]') ifFalse: [^self]]]. super delete! ! !CompositeEvent methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:18'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^OrderedCollectionInspector! ! !CompositionScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 02:06'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | "Set up margins" leftMargin _ lineRectangle left. leftSide ifTrue: [leftMargin _ leftMargin + (firstLine ifTrue: [textStyle firstIndent] ifFalse: [textStyle restIndent])]. destX _ spaceX _ leftMargin. rightMargin _ lineRectangle right. rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent]. lastIndex _ startIndex. "scanning sets last index" destY _ lineRectangle top. lineHeight _ baseline _ 0. "Will be increased by setFont" self setStopConditions. "also sets font" runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. spaceCount _ 0. self handleIndentation. leftMargin _ destX. line leftMargin: leftMargin. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'scanning' stamp: 'hmm 7/20/2000 18:24'! composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex. destY _ 0. rightMargin _ aParagraph rightMarginForComposition. leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose']. lastIndex _ startIndex. "scanning sets last index" lineHeight _ textStyle lineGrid. "may be increased by setFont:..." baseline _ textStyle baseline. self setStopConditions. "also sets font" self handleIndentation. runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ TextLineInterval start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0. spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/4/2001 13:52'! columnBreak "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 12/17/2001 02:13'! placeEmbeddedObject: anchoredMorph | descent | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit" "But if it's the first character then leave it here" lastIndex < line first ifFalse:[ line stop: lastIndex-1. ^ false]]. descent _ lineHeight - baseline. lineHeight _ lineHeight max: anchoredMorph height. baseline _ lineHeight - descent. line stop: lastIndex. ^ true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'RAA 5/7/2001 10:12'! setFont super setFont. stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #space. wantsColumnBreaks == true ifTrue: [ stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. ]. ! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:59'! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. ^false ! ! !CompoundTextConverter methodsFor: 'initialize-release' stamp: 'yo 8/13/2003 11:45'! initialize state _ CompoundTextConverterState g0Size: 1 g1Size: 1 g0Leading: 0 g1Leading: 0 charSize: 1 streamPosition: 0. acceptingEncodings _ #(ascii iso88591 jisx0208 gb2312 ksc5601 ksx1001 ) copy. ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 3/17/2004 22:17'! nextFromStream: aStream | character character2 size leadingChar offset result | aStream isBinary ifTrue: [^ aStream basicNext]. character _ aStream basicNext. character ifNil: [^ nil]. character == Character escape ifTrue: [ self parseShiftSeqFromStream: aStream. character _ aStream basicNext. character ifNil: [^ nil]]. character asciiValue < 128 ifTrue: [ size _ state g0Size. leadingChar _ state g0Leading. offset _ 16r21. ] ifFalse: [ size _state g1Size. leadingChar _ state g1Leading. offset _ 16rA1. ]. size = 1 ifTrue: [ leadingChar = 0 ifTrue: [^ character] ifFalse: [^ MultiCharacter leadingChar: leadingChar code: character asciiValue] ]. size = 2 ifTrue: [ character2 _ aStream basicNext. character2 ifNil: [^ nil. "self errorMalformedInput"]. character _ character asciiValue - offset. character2 _ character2 asciiValue - offset. result _ MultiCharacter leadingChar: leadingChar code: character * 94 + character2. ^ result asUnicodeChar. "^ self toUnicode: result" ]. self error: 'unsupported encoding'. ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'yo 7/21/2004 15:49'! nextPut: aCharacter toStream: aStream | ascii leadingChar class | aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ ^ aStream basicNextPut: aCharacter. ]. aCharacter class == MultiCharacter ifTrue: [ "this shouldn't happen?" ^ aStream nextInt32Put: aCharacter value. ]. ]. aCharacter isUnicode ifTrue: [ class _ (EncodedCharSet charsetAt: aCharacter leadingChar) traditionalCharsetClass. ascii _ (class charFromUnicode: aCharacter asUnicode) charCode. leadingChar _ class leadingChar. ] ifFalse: [ ascii _ aCharacter charCode. leadingChar _ aCharacter leadingChar. ]. self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 9/16/2002 21:41'! currentCharSize ^ state charSize. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 8/18/2003 17:50'! emitSequenceToResetStateIfNeededOn: aStream Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 12:33'! restoreStateOf: aStream with: aConverterState state _ aConverterState copy. aStream position: state streamPosition. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 13:52'! saveStateOf: aStream | inst | inst _ state clone. inst streamPosition: aStream position. ^ inst. ! ! !CompoundTextConverter methodsFor: 'query' stamp: 'yo 8/23/2002 22:39'! accepts: aSymbol ^ acceptingEncodings includes: aSymbol. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:36'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar | charset | charset _ EncodedCharSet charsetAt: leadingChar. charset ifNotNil: [ charset nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ] ifNil: [ "..." ]. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 12/10/2003 15:46'! parseShiftSeqFromStream: aStream | c set target id | c _ aStream basicNext. c = $$ ifTrue: [ set _ #multibyte. c _ aStream basicNext. c = $( ifTrue: [target _ 1]. c = $) ifTrue: [target _ 2]. target ifNil: [target _ 1. id _ c] ifNotNil: [id _ aStream basicNext]. ] ifFalse: [ c = $( ifTrue: [target _ 1. set _ #nintyfour]. c = $) ifTrue: [target _ 2. set _ #nintyfour]. c = $- ifTrue: [target _ 2. set _ #nintysix]. "target = nil ifTrue: [self errorMalformedInput]." id _ aStream basicNext. ]. (set = #multibyte and: [id = $B]) ifTrue: [ state charSize: 2. target = 1 ifTrue: [ state g0Size: 2. state g0Leading: 1. ] ifFalse: [ state g1Size: 2. state g1Leading: 1. ]. ^ self ]. (set = #multibyte and: [id = $A]) ifTrue: [ state charSize: 2. target = 1 ifTrue: [ state g0Size: 2. state g0Leading: 2. ] ifFalse: [ state g1Size: 2. state g1Leading: 2. ]. ^ self ]. (set = #nintyfour and: [id = $B or: [id = $J]]) ifTrue: [ state charSize: 1. state g0Size: 1. state g0Leading: 0. ^ self ]. (set = #nintysix and: [id = $A]) ifTrue: [ state charSize: 1. state g1Size: 1. state g1Leading: 0. ^ self ]. "self errorUnsupported." ! ! !CompoundTextConverter commentStamp: '' prior: 0! Text converter for X Compound Text.! !CompoundTextConverter class methodsFor: 'utilities' stamp: 'yo 10/24/2002 14:16'! encodingNames ^ #('iso-2022-jp' 'x-ctext') copy ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! charSize ^ charSize ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! charSize: s charSize _ s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g0Leading ^ g0Leading ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g0Leading: l g0Leading _ l. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g0Size ^ g0Size ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g0Size: s g0Size _ s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 14:37'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos g0Size _ g0. g1Size _ g1. g0Leading _ g0l. g1Leading _ g1l. charSize _ cSize. streamPosition _ pos. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! g1Leading ^ g1Leading ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Leading: l g1Leading _ l. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g1Size ^ g1Size ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Size: s g1Size _ s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 11/4/2002 12:31'! printOn: aStream aStream nextPut: $(; nextPutAll: g0Size printString; space; nextPutAll: g1Size printString; space; nextPutAll: g0Leading printString; space; nextPutAll: g1Leading printString; space; nextPutAll: charSize printString; space; nextPutAll: streamPosition printString. aStream nextPut: $). ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! streamPosition ^ streamPosition ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:40'! streamPosition: pos streamPosition _ pos. ! ! !CompoundTextConverterState commentStamp: '' prior: 0! This represents the state of CompoundTextConverter.! !CompoundTextConverterState class methodsFor: 'instance creation' stamp: 'yo 8/19/2002 17:04'! g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ^ (self new) g0Size: g0 g1Size: g1 g0Leading: g0l g1Leading: g1l charSize: cSize streamPosition: pos ; yourself. ! ! !CompoundTileMorph methodsFor: 'access' stamp: 'nk 10/14/2004 11:37'! myMorph ^nil! ! !CompoundTileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 12/13/2001 16:42'! wantsDroppedMorph: aMorph event: evt "Removing this method entirely would be okay someday" ^ false " ^ (aMorph isKindOf: TileMorph) or: [(aMorph isKindOf: ScriptEditorMorph) or: [(aMorph isKindOf: CompoundTileMorph) or: [aMorph isKindOf: CommandTilesMorph]]]" ! ! !CompoundTileMorph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:57'! isTileEditor "Yes I am" ^true! ! !CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:22'! handlesMouseDown: evt ^true! ! !CompoundTileMorph methodsFor: 'event handling' stamp: 'tk 2/28/2001 21:25'! mouseDown: evt "Pretend we picked up the tile and then put it down for a trial positioning." "The essence of ScriptEditor mouseEnter:" | ed ss guyToTake | " self isPartsDonor ifTrue:[ dup _ self duplicate. evt hand attachMorph: dup. dup position: evt position. ^self]. submorphs isEmpty never true ifTrue: [^ self]. " (ed _ self enclosingEditor) ifNil: [^evt hand grabMorph: self]. guyToTake _ self. owner class == TilePadMorph ifTrue: ["picking me out of another phrase" (ss _ submorphs first) class == TilePadMorph ifTrue: [ss _ ss submorphs first]. guyToTake _ ss veryDeepCopy]. evt hand grabMorph: guyToTake. ed startStepping. ed mouseEnterDragging: evt. ed setProperty: #justPickedUpPhrase toValue: true. ! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:21'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange muchLighter! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'sw 7/22/2004 00:13'! initialize "initialize the state of the receiver" | r stringMorph | super initialize. self layoutInset: 2. self listDirection: #topToBottom. self hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellInset: (0 @ 1); minCellSize: (200@14). "NB: hResizing gets reset to #spaceFill below, after the standalone structure is created" r _ AlignmentMorph newRow color: color; layoutInset: 0. r setProperty: #demandsBoolean toValue: true. r addMorphBack: (Morph new color: color; extent: 2 @ 5). "spacer" stringMorph _ StringMorph new contents: 'Test' translated. stringMorph name: 'Test'. r addMorphBack: stringMorph. r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (testPart _ BooleanScriptEditor new borderWidth: 0; layoutInset: 1). testPart color: Color transparent. testPart hResizing: #spaceFill. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 30 @ 5). "spacer" stringMorph _ StringMorph new contents: 'Yes' translated. stringMorph name: 'Yes'. r addMorphBack: stringMorph. r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (yesPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). yesPart hResizing: #spaceFill. yesPart color: Color transparent. self addMorphBack: r. r _ AlignmentMorph newRow color: color; layoutInset: 0. r addMorphBack: (Morph new color: color; extent: 35 @ 5). "spacer" stringMorph _ StringMorph new contents: 'No' translated. stringMorph name: 'No'. r addMorphBack: stringMorph. r addMorphBack: (Morph new color: color; extent: 5 @ 5). "spacer" r addMorphBack: (noPart _ ScriptEditorMorph new borderWidth: 0; layoutInset: 2). noPart hResizing: #spaceFill. noPart color: Color transparent. self addMorphBack: r. self bounds: self fullBounds. self updateWordingToMatchVocabulary. self hResizing:#spaceFill ! ! !CompoundTileMorph methodsFor: 'initialization' stamp: 'nk 10/8/2004 11:56'! updateWordingToMatchVocabulary | labels | labels _ OrderedCollection new. self submorphs do: [:submorph | submorph submorphs do: [:subsubmorph | subsubmorph class == StringMorph ifTrue: [labels add: subsubmorph]]]. labels do: [:label | label knownName ifNotNilDo: [ :nm | label acceptValue: nm translated ]] ! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'ar 2/6/2001 22:07'! recompileScript "Pertains only when the test is outside a script?!!" ! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/27/2001 17:27'! resultType "Answer the result type of the receiver" ^ #Command! ! !CompoundTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/15/2001 16:36'! tileRows "Answer a list of tile rows, in this case just one though it's compound" ^ Array with: (Array with: self veryDeepCopy)! ! !CompoundTileMorph methodsFor: 'testing' stamp: 'yo 11/4/2002 20:33'! isTileScriptingElement ^ true ! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! binary self error: 'Compressed source files are ascii to the user (though binary underneath)'! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/1/2003 22:36'! close self flush. segmentFile close! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 17:54'! openOn: aFile "Open the receiver." segmentFile _ aFile. segmentFile binary. segmentFile size > 0 ifTrue: [self readHeaderInfo. "If file exists, then read the parameters"] ifFalse: [self segmentSize: 20000 maxSize: 34000000. "Otherwise write default values"]! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:13'! openReadOnly segmentFile openReadOnly! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/5/2003 22:41'! readHeaderInfo | valid a b | segmentFile position: 0. segmentSize _ segmentFile nextNumber: 4. nSegments _ segmentFile nextNumber: 4. endOfFile _ segmentFile nextNumber: 4. segmentFile size < (nSegments+1 + 3 * 4) ifTrue: "Check for reasonable segment info" [self error: 'This file is not in valid compressed source format']. segmentTable _ (1 to: nSegments+1) collect: [:x | segmentFile nextNumber: 4]. segmentTable first ~= self firstSegmentLoc ifTrue: [self error: 'This file is not in valid compressed source format']. valid _ true. 1 to: nSegments do: "Check that segment offsets are ascending" [:i | a _ segmentTable at: i. b _ segmentTable at: i+1. (a = 0 and: [b ~= 0]) ifTrue: [valid _ false]. (a ~= 0 and: [b ~= 0]) ifTrue: [b <= a ifTrue: [valid _ false]]]. valid ifFalse: [self error: 'This file is not in valid compressed source format']. dirty _ false. self position: 0.! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/3/2003 10:09'! readOnlyCopy ^ self class on: segmentFile readOnlyCopy! ! !CompressedSourceStream methodsFor: 'open/close' stamp: 'di 11/2/2003 23:07'! test "FileDirectory default deleteFileNamed: 'test.stc'. (CompressedSourceStream on: (FileStream newFileNamed: 'test.stc')) fileOutChanges" "FileDirectory default deleteFileNamed: 'test2.stc'. ((CompressedSourceStream on: (FileStream newFileNamed: 'test2.stc')) segmentSize: 100 nSegments: 1000) fileOutChanges" "FileDirectory default deleteFileNamed: 'test3.st'. (FileStream newFileNamed: 'test3.st') fileOutChanges" "(CompressedSourceStream on: (FileStream oldFileNamed: 'test.stc')) contentsOfEntireFile" ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/3/2003 00:41'! atEnd position >= readLimit ifFalse: [^ false]. "more in segment" ^ self position >= endOfFile "more in file"! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 22:48'! contentsOfEntireFile | contents | self position: 0. contents _ self next: self size. self close. ^ contents! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 19:50'! flush dirty ifTrue: ["Write buffer, compressed, to file, and also write the segment offset and eof" self writeSegment].! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/20/2003 12:03'! next position >= readLimit ifTrue: [^ (self next: 1) at: 1] ifFalse: [^ collection at: (position _ position + 1)]! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:45'! next: n | str | n <= (readLimit - position) ifTrue: ["All characters are available in buffer" str _ collection copyFrom: position + 1 to: position + n. position _ position + n. ^ str]. "Read limit could be segment boundary or real end of file" (readLimit + self segmentOffset) = endOfFile ifTrue: ["Real end of file -- just return what's available" ^ self next: readLimit - position]. "Read rest of segment. Then (after positioning) read what remains" str _ self next: readLimit - position. self position: self position. ^ str , (self next: n - str size) ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 11:27'! nextPut: char "Slow, but we don't often write, and then not a lot" self nextPutAll: char asString. ^ char! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 12:06'! nextPutAll: str | n nInSeg | n _ str size. n <= (writeLimit - position) ifTrue: ["All characters fit in buffer" collection replaceFrom: position + 1 to: position + n with: str. dirty _ true. position _ position + n. readLimit _ readLimit max: position. endOfFile _ endOfFile max: self position. ^ str]. "Write what fits in segment. Then (after positioning) write what remains" nInSeg _ writeLimit - position. nInSeg = 0 ifTrue: [self position: self position. self nextPutAll: str] ifFalse: [self nextPutAll: (str first: nInSeg). self position: self position. self nextPutAll: (str allButFirst: nInSeg)] ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 09:27'! position ^ position + self segmentOffset! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/2/2003 22:24'! position: newPosition | compressedBuffer newSegmentIndex | newPosition > endOfFile ifTrue: [self error: 'Attempt to position beyond the end of file']. newSegmentIndex _ (newPosition // segmentSize) + 1. newSegmentIndex ~= segmentIndex ifTrue: [self flush. segmentIndex _ newSegmentIndex. newSegmentIndex > nSegments ifTrue: [self error: 'file size limit exceeded']. segmentFile position: (segmentTable at: segmentIndex). (segmentTable at: segmentIndex+1) = 0 ifTrue: [newPosition ~= endOfFile ifTrue: [self error: 'Internal logic error']. collection size = segmentSize ifFalse: [self error: 'Internal logic error']. "just leave garbage beyond end of file"] ifFalse: [compressedBuffer _ segmentFile next: ((segmentTable at: segmentIndex+1) - (segmentTable at: segmentIndex)). collection _ (GZipReadStream on: compressedBuffer) upToEnd asString]. readLimit _ collection size min: endOfFile - self segmentOffset]. position _ newPosition \\ segmentSize. ! ! !CompressedSourceStream methodsFor: 'access' stamp: 'di 11/1/2003 11:41'! size ^ endOfFile ifNil: [0]! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/20/2003 12:45'! fileID "Only needed for OSProcess stuff" ^ segmentFile fileID ! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:35'! firstSegmentLoc "First segment follows 3 header words and segment table" ^ (3 + nSegments+1) * 4! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/2/2003 09:24'! segmentOffset ^ segmentIndex - 1 * segmentSize! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/5/2003 22:41'! segmentSize: segSize maxSize: maxSize "Note that this method can be called after the initial open, provided that no writing has yet taken place. This is how to override the default segmentation." self size = 0 ifFalse: [self error: 'Cannot set parameters after the first write']. segmentFile position: 0. segmentFile nextNumber: 4 put: (segmentSize _ segSize). segmentFile nextNumber: 4 put: (nSegments _ maxSize // segSize + 2). segmentFile nextNumber: 4 put: (endOfFile _ 0). segmentTable _ Array new: nSegments+1 withAll: 0. segmentTable at: 1 put: self firstSegmentLoc. "Loc of first segment, always." segmentTable do: [:i | segmentFile nextNumber: 4 put: i]. segmentIndex _ 1. collection _ String new: segmentSize. writeLimit _ segmentSize. readLimit _ 0. position _ 0. endOfFile _ 0. self writeSegment. ! ! !CompressedSourceStream methodsFor: 'private' stamp: 'di 11/5/2003 22:42'! writeSegment "The current segment must be the last in the file." | compressedSegment | segmentFile position: (segmentTable at: segmentIndex). compressedSegment _ ByteArray streamContents: [:strm | (GZipWriteStream on: strm) nextPutAll: collection asByteArray; close]. segmentFile nextPutAll: compressedSegment. segmentTable at: segmentIndex + 1 put: segmentFile position. segmentFile position: 2 * 4. segmentFile nextNumber: 4 put: endOfFile. segmentFile position: (segmentIndex + 3) * 4. segmentFile nextNumber: 4 put: (segmentTable at: segmentIndex + 1). dirty _ false! ! !CompressedSourceStream commentStamp: 'di 11/3/2003 17:58' prior: 0! I implement a file format that compresses segment by segment to allow incremental writing and browsing. Note that the file can only be written at the end. Structure: segmentFile The actual compressed file. segmentSize This is the quantum of compression. The virtual file is sliced up into segments of this size. nSegments The maximum number of segments to which this file can be grown. endOfFile The user's endOfFile pointer. segmentTable When a file is open, this table holds the physical file positions of the compressed segments. segmentIndex Index of the most recently accessed segment. Inherited from ReadWriteStream... collection The segment buffer, uncompressed position This is the position *local* to the current segment buffer readLimit ReadLimit for the current buffer writeLimit WriteLimit for the current buffer Great care must be exercised to distinguish between the position relative to the segment buffer and the full file position (and, or course, the segment file position ;-). The implementation defaults to a buffer size of 20k, and a max file size of 34MB (conveniently chosen to be greater than the current 33MB limit of source code pointers). The format of the file is as follows: segmentSize 4 bytes nSegments 4 bytes endOfFile 4 bytes segmentTable 4 bytes * (nSegments+1) beginning of first compressed segment It is possible to override the default allocation by sending the message #segmentSize:nSegments: immediately after opening a new file for writing, as follows: bigFile _ (CompressedSourceStream on: (FileStream newFileNamed: 'biggy.stc')) segmentSize: 50000 maxSize: 200000000 The difference between segment table entries reveals the size of each compressed segment. When a file is being written, it may lack the final segment, but any flush, position:, or close will force a dirty segment to be written.! !CompressedSourceStream class methodsFor: 'as yet unclassified' stamp: 'di 11/1/2003 22:58'! on: aFile ^ self basicNew openOn: aFile! ! !ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0! Signals a prematurely closed connection. ! !ConnectionQueue methodsFor: 'private' stamp: 'mu 8/9/2003 14:58'! listenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." | newConnection | socket _ Socket newTCP. "We'll accept four simultanous connections at the same time" socket listenOn: portNumber backlogSize: 4. "If the listener is not valid then the we cannot use the BSD style accept() mechanism." socket isValid ifFalse: [^self oldStyleListenLoop]. [true] whileTrue: [ socket isValid ifFalse: [ "socket has stopped listening for some reason" socket destroy. (Delay forMilliseconds: 10) wait. ^self listenLoop ]. newConnection _ socket waitForAcceptFor: 10. (newConnection notNil and:[newConnection isConnected]) ifTrue: [accessSema critical: [connections addLast: newConnection]. newConnection _ nil]. self pruneStaleConnections]. ! ! !ConnectionQueue methodsFor: 'private' stamp: 'mir 5/15/2003 18:28'! oldStyleListenLoop "Private!! This loop is run in a separate process. It will establish up to maxQueueLength connections on the given port." "Details: When out of sockets or queue is full, retry more frequently, since a socket may become available, space may open in the queue, or a previously queued connection may be aborted by the client, making it available for a fresh connection." "Note: If the machine is disconnected from the network while the server is running, the currently waiting socket will go from 'isWaitingForConnection' to 'unconnected', and attempts to create new sockets will fail. When this happens, delete the broken socket and keep trying to create a socket in case the network connection is re-established. Connecting and disconnecting was tested under PPP on Mac system 8.1. It is not if this will work on other platforms." [true] whileTrue: [ ((socket == nil) and: [connections size < maxQueueLength]) ifTrue: [ "try to create a new socket for listening" socket _ Socket createIfFail: [nil]]. socket == nil ifTrue: [(Delay forMilliseconds: 100) wait] ifFalse: [ socket isUnconnected ifTrue: [socket listenOn: portNumber]. [socket waitForConnectionFor: 10] on: ConnectionTimedOut do: [:ex | socket isConnected ifTrue: [ "connection established" accessSema critical: [connections addLast: socket]. socket _ nil] ifFalse: [ socket isWaitingForConnection ifFalse: [socket destroy. socket _ nil]]]]. "broken socket; start over" self pruneStaleConnections]. ! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! host ^ host! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber host _ addressOrHostName. port _ portNumber! ! !ConnectionRefused methodsFor: 'accessing' stamp: 'len 12/14/2002 11:58'! port ^ port! ! !ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0! Signals that a connection to the specified host and port was refused. host host which refused the connection port prot to which the connection was refused ! !ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber ^ self new host: addressOrHostName port: portNumber! ! !ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0! Signals that a connection attempt timed out. ! !ContextPart methodsFor: 'accessing' stamp: 'ajh 2/9/2003 00:21'! methodNode | selector methodClass | selector _ self receiver class selectorAtMethod: self method setClass: [:mclass | methodClass _ mclass]. ^ self method methodNodeDecompileClass: methodClass selector: selector! ! !ContextPart methodsFor: 'accessing' stamp: 'nk 2/20/2004 16:50'! methodNodeFormattedAndDecorated: decorate "Answer a method node made from pretty-printed (and colorized, if decorate is true) source text." | selector methodClass | selector _ self receiver class selectorAtMethod: self method setClass: [:mclass | methodClass _ mclass]. ^ self method methodNodeFormattedDecompileClass: methodClass selector: selector decorate: decorate! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 7/6/2003 20:38'! jump: distance if: condition "Simulate the action of a 'conditional jump' bytecode whose offset is the argument, distance, and whose condition is the argument, condition." | bool | bool _ self pop. (bool == true or: [bool == false]) ifFalse: [ ^self send: #mustBeBooleanIn: to: bool with: {self} super: false]. (bool eqv: condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:35'! methodReturnConstant: value "Simulate the action of a 'return constant' bytecode whose value is the argument, value. This corresponds to a source expression like '^0'." ^ self return: value from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34'! methodReturnReceiver "Simulate the action of a 'return receiver' bytecode. This corresponds to the source expression '^self'." ^ self return: self receiver from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 1/24/2003 16:34'! methodReturnTop "Simulate the action of a 'return top of stack' bytecode. This corresponds to source expressions like '^something'." ^ self return: self pop from: self home! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44'! return: value from: aSender "For simulation. Roll back self to aSender and return value from it. Execute any unwind blocks on the way. ASSUMES aSender is a sender of self" | newTop ctxt | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false]. newTop _ aSender sender. ctxt _ self findNextUnwindContextUpTo: newTop. ctxt ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^ newTop ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'hmm 7/17/2001 20:52'! send: selector super: superFlag numArgs: numArgs "Simulate the action of bytecodes that send a message with selector, selector. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method. The arguments of the message are found in the top numArgs locations on the stack and the receiver just below them." | receiver arguments answer | arguments _ Array new: numArgs. numArgs to: 1 by: -1 do: [ :i | arguments at: i put: self pop]. receiver _ self pop. selector == #doPrimitive:method:receiver:args: ifTrue: [answer _ receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4). self push: answer. ^self]. QuickStep == self ifTrue: [ QuickStep _ nil. ^self quickSend: selector to: receiver with: arguments super: superFlag]. ^self send: selector to: receiver with: arguments super: superFlag! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/25/2001 00:12'! contextStack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 100000! ! !ContextPart methodsFor: 'debugger access' stamp: 'nk 7/29/2004 10:09'! errorReportOn: strm "Write a detailed error report on the stack (above me) on a stream. For both the error file, and emailing a bug report. Suppress any errors while getting printStrings. Limit the length." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: SmalltalkImage current platformName asString; nextPutAll: ' - '; nextPutAll: SmalltalkImage current asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: SmalltalkImage current lastUpdateString asString; nextPutAll: ']'; cr. strm cr. SecurityManager default printStateOn: strm. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." cnt _ 0. startPos _ strm position. aContext _ self. [aContext notNil and: [(cnt _ cnt + 1) < 5]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext _ aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext _ self. cnt _ 0. [aContext == nil] whileFalse: [cnt _ cnt + 1. cnt = 5 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+4000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 60 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext _ aContext sender]. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 9/7/2002 21:15'! methodSelector "Answer the selector of the method that created the receiver." ^self receiver class selectorAtMethod: self method setClass: [:ignored]! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03'! singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender _ nil. pc _ nil. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 2/9/2003 12:25'! tempNames "Answer an OrderedCollection of the names of the receiver's temporary variables, which are strings." ^ self methodNode tempNames! ! !ContextPart methodsFor: 'debugger access' stamp: 'tk 10/19/2001 10:20'! tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" | aStream | aStream _ WriteStream on: (String new: 100). self tempNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab. aStream nextPutAll: ((self tempAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)). aStream cr]. ^aStream contents! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 3/25/2004 00:07'! jump "Abandon thisContext and resume self instead (using the same current process). You may want to save thisContext's sender before calling this so you can jump back to it. Self MUST BE a top context (ie. a suspended context or a abandoned context that was jumped out of). A top context already has its return value on its stack (see Interpreter>>primitiveSuspend and other suspending primitives). thisContext's sender is converted to a top context (by pushing a nil return value on its stack) so it can be jump back to." | top | "Make abandoned context a top context (has return value (nil)) so it can be jumped back to" thisContext sender push: nil. "Pop self return value then return it to self (since we jump to self by returning to it)" stackp = 0 ifTrue: [self stepToSendOrReturn]. stackp = 0 ifTrue: [self push: nil]. "must be quick return self/constant" top _ self pop. thisContext privSender: self. ^ top! ! !ContextPart methodsFor: 'controlling' stamp: 'hmm 7/17/2001 20:57'! quickSend: selector to: receiver with: arguments super: superFlag "Send the given selector with arguments in an environment which closely resembles the non-simulating environment, with an interjected unwind-protected block to catch nonlocal returns. Attention: don't get lost!!" | oldSender contextToReturnTo result lookupClass | contextToReturnTo _ self. lookupClass _ superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [receiver class]. [oldSender _ thisContext sender swapSender: self. result _ receiver perform: selector withArguments: arguments inSuperclass: lookupClass. thisContext sender swapSender: oldSender] ifCurtailed: [ contextToReturnTo _ thisContext sender receiver. "The block context returning nonlocally" contextToReturnTo jump: -1. "skip to front of return bytecode causing this unwind" contextToReturnTo nextByte = 16r7C ifTrue: [ "If it was a returnTop, push the value to be returned. Otherwise the value is implicit in the bytecode" contextToReturnTo push: (thisContext sender tempAt: 1)]. thisContext swapSender: thisContext home sender. "Make this block return to the method's sender" contextToReturnTo]. contextToReturnTo push: result. ^contextToReturnTo! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'! restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. ctxt _ thisContext. [ ctxt _ ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. unwindBlock ifNotNil: [ ctxt tempAt: 1 put: nil. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. self jump. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 6/27/2003 22:17'! resume "Roll back thisContext to self and resume. Execute unwind blocks when rolling back. ASSUMES self is a sender of thisContext" self resume: nil! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:32'! resume: value "Unwind thisContext to self and resume with value as result of last send. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt _ thisContext. [ ctxt _ ctxt findNextUnwindContextUpTo: self. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. unwindBlock ifNotNil: [ ctxt tempAt: 1 put: nil. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: self. ^ value ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'! return "Unwind until my sender is on top" self return: self receiver! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27'! return: value "Unwind thisContext to self and return value to self's sender. Execute any unwind blocks while unwinding. ASSUMES self is a sender of thisContext" sender ifNil: [self cannotReturn: value to: sender]. sender resume: value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 15:30'! return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. sendr ifNil: [^ nil]. ^ sendr push: value! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:20'! runUntilErrorOrReturnFrom: aSender "ASSUMES aSender is a sender of self. Execute self's stack until aSender returns or an unhandled exception is raised. Return a pair containing the new top context and a possibly nil exception. The exception is not nil if it was raised before aSender returned and it was not handled. The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it." "Self is run by jumping directly to it (the active process abandons thisContext and executes self). However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated. We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised. In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext." | error ctxt here topContext | here _ thisContext. "Insert ensure and exception handler contexts under aSender" error _ nil. ctxt _ aSender insertSender: (ContextPart contextOn: UnhandledError do: [:ex | error ifNil: [ error _ ex exception. topContext _ thisContext. ex resumeUnchecked: here jump] ifNotNil: [ex pass] ]). ctxt _ ctxt insertSender: (ContextPart contextEnsure: [error ifNil: [ topContext _ thisContext. here jump] ]). self jump. "Control jumps to self" "Control resumes here once above ensure block or exception handler is executed" ^ error ifNil: [ "No error was raised, remove ensure context by stepping until popped" [ctxt isDead] whileFalse: [topContext _ topContext stepToCallee]. {topContext. nil} ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" {topContext. error} ]. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/24/2003 00:56'! terminate "Make myself unresumable." sender _ nil. pc _ nil. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'! terminateTo: previousContext "Terminate all the Contexts between me and previousContext, if previousContext is on my Context stack. Make previousContext my sender." | currentContext sendingContext | (self hasSender: previousContext) ifTrue: [ currentContext _ sender. [currentContext == previousContext] whileFalse: [ sendingContext _ currentContext sender. currentContext terminate. currentContext _ sendingContext]]. sender _ previousContext! ! !ContextPart methodsFor: 'printing' stamp: 'tk 10/19/2001 11:24'! printDetails: strm "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing." | str | self printOn: strm. strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str _ [self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [:err :rcvr | '<>']. strm nextPutAll: str. strm peekLast == Character cr ifFalse: [strm cr].! ! !ContextPart methodsFor: 'printing' stamp: 'ajh 3/17/2003 09:25'! printOn: aStream | selector class mclass | self method == nil ifTrue: [^ super printOn: aStream]. selector _ (class _ self receiver class) selectorAtMethod: self method setClass: [:c | mclass _ c]. selector == #? ifTrue: [aStream nextPut: $?; print: self method who. ^self]. aStream nextPutAll: class name. mclass == class ifFalse: [aStream nextPut: $(. aStream nextPutAll: mclass name. aStream nextPut: $)]. aStream nextPutAll: '>>'. aStream nextPutAll: selector. selector = #doesNotUnderstand: ifTrue: [ aStream space. (self tempAt: 1) selector printOn: aStream. ]. ! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current ctxt1 | ctxt _ aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current _ ctxt. ctxt1 _ ctxt quickStep. ctxt1 ifNil: [self halt]. ctxt _ ctxt1]. ^self stepToSendOrReturn! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/15/2001 20:58'! quickStep "If the next instruction is a send, just perform it. Otherwise, do a normal step." self willReallySend ifTrue: [QuickStep _ self]. ^self step! ! !ContextPart methodsFor: 'system simulation' stamp: 'ajh 1/24/2003 22:54'! stepToCallee "Step to callee or sender" | ctxt | ctxt _ self. [(ctxt _ ctxt step) == self] whileTrue. ^ ctxt! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:48'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willReallySend | self willReturn | self willStore] whileFalse: [ ctxt _ self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 5/20/2004 16:27'! activateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender" ^ self activateMethod: ContextPart theReturnMethod withArgs: {value} receiver: aContext class: aContext class! ! !ContextPart methodsFor: 'private' stamp: 'ajh 6/29/2003 15:32'! cannotReturn: result to: homeContext "The receiver tried to return result to homeContext that no longer exists." ^ BlockCannotReturn new result: result; deadHome: homeContext; signal! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/27/2003 21:18'! copyTo: aContext blocks: dict "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home." | copy | self == aContext ifTrue: [^ nil]. copy _ self copy. dict at: self ifPresent: [:blocks | blocks do: [:b | b privHome: copy]]. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 00:50'! cut: aContext "Cut aContext and its senders from my sender chain" | ctxt callee | ctxt _ self. [ctxt == aContext] whileFalse: [ callee _ ctxt. ctxt _ ctxt sender. ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. ]. callee privSender: nil. ! ! !ContextPart methodsFor: 'private' stamp: 'hg 10/2/2001 20:44'! doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message." | value | "Simulation guard" "If successful, push result and return resuming context, else ^ PrimitiveFailToken" (primitiveIndex = 19) ifTrue:[ Debugger openContext: self label:'Code simulation error' contents: nil]. (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) ifTrue: [^self push: ((BlockContext newForMethod: receiver home method) home: receiver home startpc: pc + 2 nargs: (arguments at: 1))]. (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) ifTrue: [^receiver pushArgs: arguments from: self]. primitiveIndex = 83 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: (arguments at: 2) super: false]. arguments size > 6 ifTrue: [^ PrimitiveFailToken]. primitiveIndex = 117 ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments]. value == PrimitiveFailToken ifTrue: [^ PrimitiveFailToken] ifFalse: [^ self push: value]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59'! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt _ aContext bottomContext. ctxt privSender: self sender. self privSender: aContext. ^ ctxt! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'! privSender: aContext sender _ aContext! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 01:30'! canHandleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then return true, otherwise forward this message to the next handler context. If none left, return false (see nil>>canHandleSignal:)" ^ (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) or: [self nextHandlerContext canHandleSignal: exception]. ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 19:27'! findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." | ctx | ctx _ self. [ctx isHandlerContext ifTrue:[^ctx]. (ctx _ ctx sender) == nil ] whileFalse. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/23/2000 16:37'! findNextUnwindContextUpTo: aContext "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." | ctx | ctx _ self. [(ctx _ ctx sender) == nil or: [ctx == aContext]] whileFalse: [ ctx isUnwindContext ifTrue: [^ctx]]. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 6/27/2003 20:47'! handleSignal: exception "Sent to handler (on:do:) contexts only. If my exception class (first arg) handles exception then execute my handle block (second arg), otherwise forward this message to the next handler context. If none left, execute exception's defaultAction (see nil>>handleSignal:)." | val | (((self tempAt: 1) handles: exception) and: [self tempAt: 3]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. self tempAt: 3 put: false. "disable self while executing handle block" val _ [(self tempAt: 2) valueWithPossibleArgs: {exception}] ensure: [self tempAt: 3 put: true]. self return: val. "return from self if not otherwise directed in handle block" ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'! isHandlerContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'! isUnwindContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'! nextHandlerContext ^ self sender findNextHandlerContextStarting! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 1/21/2003 17:59'! unwindTo: aContext | ctx unwindBlock | ctx := self. [(ctx _ ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ unwindBlock := ctx tempAt: 1. unwindBlock == nil ifFalse: [ ctx tempAt: 1 put: nil. unwindBlock value] ]. ! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 12:35'! blockHome ^ self! ! !ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'! bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [:c | c sender isNil]! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'! copyStack ^ self copyTo: nil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 21:20'! copyTo: aContext "Copy self and my sender chain down to, but not including, aContext. End of copied chain will have nil sender. BlockContexts whose home is also copied will point to the copy. However, blockContexts that are not on the stack but may be later will not have their home pointing in the new copied thread. So an error will be raised if one of these tries to return directly to its home. It is best to use BlockClosures instead. They only hold a ContextTag, which will work for all copies of the original home context." ^ self copyTo: aContext blocks: IdentityDictionary new! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:12'! findContextSuchThat: testBlock "Search self and my sender chain for first one that satisfies testBlock. Return nil if none satisfy" | ctxt | ctxt _ self. [ctxt isNil] whileFalse: [ (testBlock value: ctxt) ifTrue: [^ ctxt]. ctxt _ ctxt sender. ]. ^ nil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 19:42'! hasContext: aContext "Answer whether aContext is me or one of my senders" ^ (self findContextSuchThat: [:c | c == aContext]) notNil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'! isDead "Has self finished" ^ pc isNil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 22:28'! secondFromBottom "Return the second from bottom of my sender chain" self sender ifNil: [^ nil]. ^ self findContextSuchThat: [:c | c sender sender isNil]! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextEnsure: block "Create an #ensure: context that is ready to return from executing its receiver" | ctxt chain | ctxt _ thisContext. [chain _ thisContext sender cut: ctxt. ctxt jump] ensure: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 1/24/2003 14:31'! contextOn: exceptionClass do: block "Create an #on:do: context that is ready to return from executing its receiver" | ctxt chain | ctxt _ thisContext. [chain _ thisContext sender cut: ctxt. ctxt jump] on: exceptionClass do: block. "jump above will resume here without unwinding chain" ^ chain! ! !ContextPart class methodsFor: 'special context creation' stamp: 'ajh 5/20/2004 16:25'! theReturnMethod | meth | meth _ self lookupSelector: #return:. meth primitive = 0 ifFalse: [^ self error: 'expected #return: to not be a primitive']. ^ meth! ! !ContextVariablesInspector methodsFor: 'accessing' stamp: 'apb 7/26/2004 16:53'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection. Because no object's inspectorClass method answers this class, it is OK for this method to override Inspector >> inspect: " object _ anObject. self initialize ! ! !ControlManager methodsFor: 'accessing' stamp: 'sw 5/4/2001 23:20'! controllersSatisfying: aBlock "Return a list of scheduled controllers satisfying aBlock" ^ (scheduledControllers ifNil: [^ #()]) select: [:aController | (aBlock value: aController) == true]! ! !ControlManager methodsFor: 'scheduling' stamp: 'ajh 12/31/2001 15:15'! spawnNewProcess self activeController: self screenController! ! !Controller methodsFor: 'view access' stamp: 'apb 7/14/2004 12:50'! inspectView view notNil ifTrue: [^ view inspect; yourself]! ! !CornerRounder methodsFor: 'all' stamp: 'ar 1/5/2002 17:26'! saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: cornerList | offset corner mask form corners rect | underBits _ Array new: 4. corners _ bounds corners. cornerList do:[:i| mask _ cornerMasks at: i. corner _ corners at: i. i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@mask height negated]. i = 3 ifTrue: [offset _ mask extent negated]. i = 4 ifTrue: [offset _ mask width negated@0]. rect _ corner + offset extent: mask extent. (aCanvas isVisible: rect) ifTrue:[ form _ aCanvas contentsOfArea: rect. form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0). underBits at: i put: form]]. ! ! !CornerRounder methodsFor: 'all' stamp: 'kfr 8/4/2003 23:28'! tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | offset corner saveBits fourColors mask outBits shadowColor corners | shadowColor _ aCanvas shadowColor. aCanvas shadowColor: nil. "for tweaking it's essential" w > 0 ifTrue:[ fourColors _ shadowColor ifNil:[aMorph borderStyle colorsAtCorners] ifNotNil:[Array new: 4 withAll: Color transparent]]. mask _ Form extent: cornerMasks first extent depth: aCanvas depth. corners _ bounds corners. cornerList do:[:i| corner _ corners at: i. saveBits _ underBits at: i. saveBits ifNotNil:[ i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@saveBits height negated]. i = 3 ifTrue: [offset _ saveBits extent negated]. i = 4 ifTrue: [offset _ saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue:[ aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]. aCanvas shadowColor: shadowColor. "restore shadow color" ! ! !CornerRounder class methodsFor: 'all' stamp: 'ar 1/5/2002 17:24'! roundCornersOf: aMorph on: aCanvas in: bounds displayBlock: displayBlock borderWidth: w corners: aList | rounder | rounder _ CR0. w = 1 ifTrue: [rounder _ CR1]. w = 2 ifTrue: [rounder _ CR2]. rounder _ rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas in: bounds corners: aList. displayBlock value. rounder tweakCornersOf: aMorph on: aCanvas in: bounds borderWidth: w corners: aList! ! !CrLfFileStream methodsFor: 'access' stamp: 'nk 9/5/2004 12:58'! lineEndConvention ^lineEndConvention! ! !CrLfFileStream commentStamp: 'ls 11/10/2002 13:32' prior: 0! I am the same as a regular file stream, except that when I am in text mode, I will automatically convert line endings between the underlying platform's convention, and Squeak's convention of carriage-return only. The goal is that Squeak text files can be treated as OS text files, and vice versa. In binary mode, I behave identically to a StandardFileStream. To enable CrLfFileStream as the default file stream class for an entire image, modify FileStream class concreteStream . There are two caveats on programming with CrLfFileStream. First, the choice of text mode versus binary mode affects which characters are visible in Squeak, and no longer just affects whether those characters are returned as Character's or as Integer's. Thus the choice of mode needs to be made very carefully, and must be based on intent instead of convenience of representation. The methods asString, asByteArray, asCharacter, and asInteger can be used to convert between character and integer representations. (Arguably, file streams should accept either strings or characters in nextPut: and nextPutAll:, but that is not the case right now.) Second, arithmetic on positions no longer works, because one character that Squeak sees (carriage return) could map to two characters in the underlying file (carriage return plus line feed, on MS Windows and MS DOS). Comparison between positions still works. (This caveat could perhaps be fixed by maintaining a map between Squeak positions and positions in the underlying file, but it is complicated. Consider, for example, updates to the middle of the file. Also, consider that text files are rarely updated in the middle of the file, and that general random access to a text file is rarely very useful. If general random access with specific file counts is desired, then the file is starting to sound like a binary file instead of a text file.) ! ]style[(448 31 1371 6 32)f1,f1LFileStream class concreteStream;,f1,f1i,f1! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 04:46'! new ^ (MultiByteFileStream new) wantsLineEndConversion: true; yourself. ! ! !CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'sw 5/4/2001 23:22'! showSharedFlaps "Answer whether shared flaps are currently showing (true) or suppressed (false). The CurrentProjectRefactoring circumlocution is in service of making it possible for shared flaps to appear on the edges of an interior subworld, I believe." ^ self xxxCurrent showSharedFlaps! ! !CurrentProjectRefactoring class methodsFor: 'flaps' stamp: 'dgd 8/31/2003 18:06'! suppressFlapsString "Answer a string characterizing whether flaps are suppressed at the moment or not" ^ (self currentFlapsSuppressed ifTrue: [''] ifFalse: ['']), 'show shared tabs (F)' translated! ! !Cursor methodsFor: 'updating' stamp: 'ls 6/17/2002 12:00'! changed: aParameter "overriden to reinstall the cursor if it is the active cursor, in case the appearance has changed. (Is this used anywhere? Do cursors really change in place these days?)" self == CurrentCursor ifTrue: [self beCursor]. super changed: aParameter! ! !Cursor methodsFor: 'displaying' stamp: 'ls 6/17/2002 11:56'! show "Make the hardware's mouse cursor look like the receiver" Sensor currentCursor: self! ! !Cursor commentStamp: '' prior: 0! I am a Form that is a possible appearance for a mouse cursor. My size is always 16x16, ever since the original implementation on the Alto. There are many examples available in the "current cursor" category of class methods. For example, "Cursor normal" and "Cursor wait". For example: Cursor wait show ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'! initBottomLeft BottomLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1111111111111111 2r1111111111111111) offset: 0@-16). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:57'! initBottomRight BottomRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r1111111111111111 2r1111111111111111) offset: -16@-16). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:02'! initCrossHair CrossHairCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0111111111111100 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000000000000 2r0) offset: -7@-7). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'di 7/30/2001 10:32'! initMenu MenuCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111100000 2r1000000000100000 2r1010011000100000 2r1000000000100000 2r1101001101100000 2r1111111111100000 2r1000000000100000 2r1011001010100000 2r1000000000100000 2r1010110010100000 2r1000000000100000 2r1010010100100000 2r1000000000100000 2r1111111111100000 0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:10'! initMove MoveCursor _ Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1100001100001100 2r1111111111111100 2r1111111111111100 0) offset: 0@0. ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:55'! initRead ReadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000000000000000 2r0001000000001000 2r0010100000010100 2r0100000000100000 2r1111101111100000 2r1000010000100000 2r1000010000100000 2r1011010110100000 2r0111101111000000 2r0 2r0 2r0 2r0 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'dew 2/14/2004 01:24'! initResizeLeft ResizeLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000101001010000 2r0001101001011000 2r0011101001011100 2r0111111001111110 2r0011101001011100 2r0001101001011000 2r0000101001010000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000001001000000 2r0000000000000000 ) offset: -7@-7 ) withMask ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 4/3/2004 11:46'! initResizeTop "Cursor initResizeTop" ResizeTopCursor _ (Cursor extent: 16@16 fromArray: #( 2r000000100000000 2r000001110000000 2r000011111000000 2r000111111100000 2r000000100000000 2r111111111111100 2r000000000000000 2r000000000000000 2r111111111111100 2r000000100000000 2r000111111100000 2r000011111000000 2r000001110000000 2r000000100000000 2r000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 18:59'! initResizeTopLeft ResizeTopLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0111110000010000 2r0111100000100000 2r0111000001000100 2r0110100010001000 2r0100010100010000 2r0000001000100000 2r0000010001000000 2r0000100010000000 2r0001000100100010 2r0010001000010110 2r0000010000001110 2r0000100000011110 2r0000000000111110 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:00'! initResizeTopRight ResizeTopRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000000000 2r0000100000111110 2r0000010000011110 2r0010001000001110 2r0001000100010110 2r0000100010100010 2r0000010001000000 2r0000001000100000 2r0000000100010000 2r0100010010001000 2r0110100001000100 2r0111000000100000 2r0111100000010000 2r0111110000000000 2r0000000000000000 2r0000000000000000) offset: -7@-7) withMask.! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:01'! initTopLeft TopLeftCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000 2r1100000000000000) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:02'! initTopRight TopRightCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r1111111111111111 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011 2r0000000000000011) offset: -16@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 21:27'! initWait WaitCursor _ (Cursor extent: 16@16 fromArray: #( 2r1111111111111100 2r1000000000000100 2r0100000000001000 2r0010000000010000 2r0001110011100000 2r0000111111000000 2r0000011110000000 2r0000011110000000 2r0000100101000000 2r0001000100100000 2r0010000110010000 2r0100001111001000 2r1000111111110100 2r1111111111111100 0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'kfr 7/12/2003 22:52'! initWrite WriteCursor _ (Cursor extent: 16@16 fromArray: #( 2r0000000000011000 2r0000000000111100 2r0000000001001000 2r0000000010010000 2r0000000100100000 2r0000001001000100 2r0000010010000100 2r0000100100001100 2r0001001000010000 2r0010010000010000 2r0111100000001000 2r0101000011111000 2r1110000110000000 2r0111111100000000 2r0 2r0) offset: 0@0). ! ! !Cursor class methodsFor: 'class initialization' stamp: 'JMM 10/21/2003 19:04'! initialize "Create all the standard cursors..." self initOrigin. self initRightArrow. self initMenu. self initCorner. self initRead. self initWrite. self initWait. BlankCursor _ Cursor new. self initXeq. self initSquare. self initNormalWithMask. self initCrossHair. self initMarker. self initUp. self initDown. self initMove. self initBottomLeft. self initBottomRight. self initResizeLeft. self initResizeTop. self initResizeTopLeft. self initResizeTopRight. self initTopLeft. self initTopRight. self makeCursorsWithMask. "Cursor initialize" ! ! !Cursor class methodsFor: 'instance creation' stamp: 'ar 8/16/2001 15:52'! resizeForEdge: aSymbol "Cursor resizeForEdge: #top" "Cursor resizeForEdge: #bottomLeft" ^self perform: ('resize', aSymbol first asString asUppercase, (aSymbol copyFrom: 2 to: aSymbol size)) asSymbol.! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! bottomLeft "Cursor bottomLeft showWhile: [Sensor waitButton]" ^BottomLeftCursor ! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:13'! bottomRight "Cursor bottomRight showWhile: [Sensor waitButton]" ^BottomRightCursor ! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:48'! resizeBottom "Cursor resizeBottom showWhile: [Sensor waitButton]" ^self resizeTop! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:46'! resizeBottomLeft "Cursor resizeBottomLeft showWhile: [Sensor waitButton]" ^self resizeTopRight! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeBottomRight "Cursor resizeBottomRight showWhile: [Sensor waitButton]" ^self resizeTopLeft! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58'! resizeLeft "Cursor resizeLeft showWhile: [Sensor waitButton]" ^ResizeLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeRight "Cursor resizeRight showWhile: [Sensor waitButton]" ^self resizeLeft! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19'! resizeTop "Cursor resizeTop showWhile: [Sensor waitButton]" ^ResizeTopCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopLeft "Cursor resizeTopLeft showWhile: [Sensor waitButton]" ^ ResizeTopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopRight "Cursor resizeTopRight showWhile: [Sensor waitButton]" ^ResizeTopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:01'! topLeft "Cursor topLeft showWhile: [Sensor waitButton]" ^ TopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02'! topRight "Cursor topRight showWhile: [Sensor waitButton]" ^ TopRightCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 9/26/2001 22:37'! webLink "Return a cursor that can be used for emphasizing web links" "Cursor webLink showWhile: [Sensor waitButton]" ^WebLinkCursor ifNil:[ WebLinkCursor _ (CursorWithMask extent: 16@16 fromArray: #(3072 4608 4608 4608 4608 5046 4681 29257 37449 37449 32769 32769 49155 16386 24582 16380 ) offset: -5@0) setMaskForm: (Form extent: 16@16 fromArray: (#(3072 7680 7680 7680 7680 8118 8191 32767 65535 65535 65535 65535 65535 32766 32766 16380 ) collect: [:bits | bits bitShift: 16]) offset: 0@0)].! ! !CursorWithMask commentStamp: '' prior: 0! A Cursor which additionally has a 16x16 transparency bitmap called a "mask". See the comment of beCursorWithMask: for details on how the mask is treated.! ]style[(97 17 40)f3,f3LCursor beCursorWithMask:;,f3! !CurveMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! initializeToStandAlone super initializeToStandAlone. self beSmoothCurve. ! ! !CurveMorph class methodsFor: 'instance creation' stamp: 'tk 11/14/2001 17:47'! arrowPrototype | aa | aa _ PolygonMorph vertices: (Array with: 5@40 with: 5@8 with: 35@8 with: 35@40) color: Color black borderWidth: 2 borderColor: Color black. aa beSmoothCurve; makeOpen; makeForwardArrow. "is already open" aa dashedBorder: {10. 10. Color red}. "A dash spec is a 3- or 5-element array with { length of normal border color. length of alternate border color. alternate border color}" aa computeBounds. ^ aa! ! !CurveMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! descriptionForPartsBin ^ self partName: 'Curve' categories: #('Graphics' 'Basic') documentation: 'A smooth wiggly curve, or a curved solid. Shift-click to get handles and move the points.'! ! !CurveMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'Curvy Arrow' categoryList: #('Basic' 'Graphics') documentation: 'A curved line with an arrowhead. Shift-click to get handles and move the points.' globalReceiverSymbol: #CurveMorph nativitySelector: #arrowPrototype} ! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:15'! initialize self registerInFlapsRegistry. ! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:16'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(CurveMorph authoringPrototype 'Curve' 'A curve') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(CurveMorph authoringPrototype 'Curve' 'A curve') forFlapNamed: 'Supplies'.]! ! !CurveMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !CustomMenu methodsFor: 'initialize-release' stamp: 'sumim 2/10/2002 01:26'! initialize labels _ OrderedCollection new. selections _ OrderedCollection new. dividers _ OrderedCollection new. lastDivider _ 0. targets _ OrderedCollection new. arguments _ OrderedCollection new ! ! !CustomMenu methodsFor: 'construction' stamp: 'sw 2/27/2001 07:52'! addList: listOfTuplesAndDashes "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc." listOfTuplesAndDashes do: [:aTuple | aTuple == #- ifTrue: [self addLine] ifFalse: [self add: aTuple first action: aTuple second]] "CustomMenu new addList: #( ('apples' buyApples) ('oranges' buyOranges) - ('milk' buyMilk)); startUp" ! ! !CustomMenu methodsFor: 'construction' stamp: 'sw 8/12/2002 17:14'! addStayUpItem "For compatibility with MenuMorph. Here it is a no-op"! ! !CustomMenu methodsFor: 'construction' stamp: 'nk 11/25/2003 10:00'! addTranslatedList: listOfTuplesAndDashes "Add a menu item to the receiver for each tuple in the given list of the form ( ). Add a line for each dash (-) in the list. The tuples may have an optional third element, providing balloon help for the item, but such an element is ignored in mvc. The first element will be translated." listOfTuplesAndDashes do: [:aTuple | aTuple == #- ifTrue: [self addLine] ifFalse: [self add: aTuple first translated action: aTuple second]] "CustomMenu new addTranslatedList: #( ('apples' buyApples) ('oranges' buyOranges) - ('milk' buyMilk)); startUp" ! ! !CustomMenu methodsFor: 'construction' stamp: 'yo 8/28/2002 22:34'! labels: labelList lines: linesArray selections: selectionsArray "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | labelList isString ifTrue: [labelArray _ labelList findTokens: String cr] ifFalse: [labelArray _ labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]. ! ! !CustomMenu methodsFor: 'invocation' stamp: 'sw 2/17/2002 04:48'! invokeOn: targetObject "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain them from my arguments" ^ self invokeOn: targetObject orSendTo: nil! ! !CustomMenu methodsFor: 'invocation' stamp: 'sw 11/16/2002 23:45'! invokeOn: targetObject orSendTo: anObject "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected. If the chosen selector has arguments, obtain appropriately. If the recipient does not respond to the resulting message, send it to the alternate object provided" | aSelector anIndex recipient | ^ (aSelector _ self startUp) ifNotNil: [anIndex _ self selection. recipient _ ((targets _ self targets) isEmptyOrNil or: [anIndex > targets size]) ifTrue: [targetObject] ifFalse: [targets at: anIndex]. aSelector numArgs == 0 ifTrue: [recipient perform: aSelector orSendTo: anObject] ifFalse: [recipient perform: aSelector withArguments: (self arguments at: anIndex)]]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'ads 2/20/2003 08:59'! add: aString subMenu: aMenu target: target selector: aSymbol argumentList: argList "Create a sub-menu with the given label. This isn't really a sub-menu the way Morphic does it; it'll just pop up another menu." self add: aString target: aMenu selector: #invokeOn: argumentList: argList asArray.! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:23'! add: aString target: target selector: aSymbol argument: arg "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given argument." self add: aString target: target selector: aSymbol argumentList: (Array with: arg)! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:18'! add: aString target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." self add: aString action: aSymbol. targets addLast: target. arguments addLast: argList asArray ! ! !CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:19'! addService: aService for: serviceUser "Append a menu item with the given service. If the item is selected, it will perform the given service." aService addServiceFor: serviceUser toMenu: self.! ! !CustomMenu methodsFor: 'compatibility' stamp: 'nk 2/15/2004 16:02'! addServices2: services for: served extraLines: linesArray services withIndexDo: [:service :i | service addServiceFor: served toMenu: self. (linesArray includes: i) ifTrue: [self addLine] ]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sumim 2/10/2002 01:20'! addServices: services for: served extraLines: linesArray services withIndexDo: [:service :i | self addService: service for: served. (linesArray includes: i) | service useLineAfter ifTrue: [self addLine]]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! arguments "Answer my arguments, initializing them to an empty collection if they're found to be nil." ^ arguments ifNil: [arguments _ OrderedCollection new]! ! !CustomMenu methodsFor: 'compatibility' stamp: 'sw 2/16/2002 00:57'! targets "Answer my targets, initializing them to an empty collection if found to be nil" ^ targets ifNil: [targets _ OrderedCollection new]! ! !DSCPostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'! fullDraw: aMorph (morphLevel = 0 and: [aMorph pagesHandledAutomatically not]) ifTrue: [pages _ pages + 1. target print: '%%Page: 1 1'; cr]. super fullDraw: aMorph. morphLevel = 0 ifTrue: [ self writeTrailer: pages. ]! ! !DSCPostscriptCanvas methodsFor: 'initialization' stamp: 'nk 1/2/2004 15:36'! writePSIdentifierRotated: rotateFlag | morphExtent pageExtent | target print: '%!!PS-Adobe-2.0'; cr; print: '%%Pages: (atend)'; cr; print: '%%DocumentFonts: (atend)'; cr. "Define initialScale so that the morph will fit the page rotated or not" savedMorphExtent := morphExtent := rotateFlag ifTrue: [psBounds extent transposed] ifFalse: [psBounds extent]. pageExtent := self defaultImageableArea extent asFloatPoint. initialScale := (printSpecs isNil or: [printSpecs scaleToFitPage]) ifTrue: [pageExtent x / morphExtent x min: pageExtent y / morphExtent y] ifFalse: [1.0]. target print: '%%BoundingBox: '; write: self defaultImageableArea; cr. target print: '%%Title: '; print: self topLevelMorph externalName; cr. target print: '%%Creator: '; print: Utilities authorName; cr. target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr. target print: '%%Orientation: '; print: (rotateFlag ifTrue: ['Landscape'] ifFalse: ['Portrait']); cr. target print: '%%EndComments'; cr. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 16:53'! endGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ target showpage; print: 'grestore'; cr ]! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 6/10/2004 13:19'! fullDrawBookMorph: aBookMorph " draw all the pages in a book morph, but only if it is the top-level morph " morphLevel = 1 ifFalse: [^ super fullDrawBookMorph: aBookMorph]. "Unfortunately, the printable 'pages' of a StackMorph are the cards, but for a BookMorph, they are the pages. Separate the cases here." (aBookMorph isKindOf: StackMorph) ifTrue: [ aBookMorph cards do: [:aCard | aBookMorph goToCard: aCard. "cause card-specific morphs to be installed" pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aBookMorph currentPage]] ifFalse: [ aBookMorph pages do: [:aPage | pages _ pages + 1. target print: '%%Page: '; write: pages; space; write: pages; cr. self drawPage: aPage]]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ]. ! ! !DSCPostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/1/2004 18:21'! setupGStateForMorph: aMorph "position the morph on the page " morphLevel == (topLevelMorph pagesHandledAutomatically ifTrue: [2] ifFalse: [1]) ifTrue: [ self writePageSetupFor: aMorph ]! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 19:56'! pageBBox | pageSize offset bbox trueExtent | trueExtent := savedMorphExtent * initialScale. "this one has been rotated" pageSize := self defaultPageSize. offset := pageSize extent - trueExtent / 2 max: 0 @ 0. bbox := offset extent: trueExtent. ^ bbox! ! !DSCPostscriptCanvas methodsFor: 'page geometry' stamp: 'nk 12/30/2003 17:22'! pageOffset ^self pageBBox origin. ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:41'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset ^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil ! ! !DSCPostscriptCanvasToDisk methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 17:39'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil self reset. psBounds := offset extent: aMorph bounds extent. topLevelMorph := aMorph. self writeHeaderRotated: rotateFlag. self fullDrawMorph: aMorph. ^ self close! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'nk 12/30/2003 16:58'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: specsOrNil | newFileName stream | ^[ (self new morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset) close ] on: PickAFileToWriteNotification do: [ :ex | newFileName _ FillInTheBlank request: 'Name of file to write:' translated initialAnswer: 'xxx',Time millisecondClockValue printString, self defaultExtension. newFileName isEmptyOrNil ifFalse: [ stream _ FileStream fileNamed: newFileName. stream ifNotNil: [ex resume: stream]. ]. ]. ! ! !DSCPostscriptCanvasToDisk class methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:43'! morphAsPostscript: aMorph rotated: rotateFlag specs: specsOrNil ^ self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: self baseOffset specs: specsOrNil ! ! !DSCPostscriptCanvasToDisk class methodsFor: 'testing' stamp: 'RAA 2/22/2001 07:41'! morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset ^self morphAsPostscript: aMorph rotated: rotateFlag offsetBy: offset specs: nil ! ! !DamageRecorder methodsFor: 'recording' stamp: 'di 11/17/2001 14:19'! recordInvalidRect: newRect "Record the given rectangle in my damage list, a list of rectangular areas of the display that should be redraw on the next display cycle." "Details: Damaged rectangles are often identical or overlap significantly. In these cases, we merge them to reduce the number of damage rectangles that must be processed when the display is updated. Moreover, above a certain threshold, we ignore the individual rectangles completely, and simply do a complete repaint on the next cycle." | mergeRect a | totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage" invalidRects do: [:rect | ((a _ (rect intersect: newRect) area) > 40 and: ["Avoid combining a vertical and horizontal rects. Can make a big diff and we only test when likely." a > (newRect area // 4) or: [a > (rect area // 4)]]) ifTrue: ["merge rectangle in place (see note below) if there is significant overlap" rect setOrigin: (rect origin min: newRect origin) truncated corner: (rect corner max: newRect corner) truncated. ^ self]]. invalidRects size >= 15 ifTrue: ["if there are too many separate areas, merge them all" mergeRect _ Rectangle merging: invalidRects. self reset. invalidRects addLast: mergeRect]. "add the given rectangle to the damage list" "Note: We make a deep copy of all rectangles added to the damage list, since rectangles in this list may be extended in place." invalidRects addLast: (newRect topLeft truncated corner: newRect bottomRight truncated). ! ! !DamageRecorder methodsFor: 'testing' stamp: 'dgd 2/22/2003 14:43'! updateIsNeeded "Return true if the display needs to be updated." ^totalRepaint or: [invalidRects notEmpty]! ! !DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'! beginReference: anObject "We're starting to read anObject. Remember it and its reference position (if we care; ReferenceStream cares). Answer the reference position." ^ 0! ! !DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:25'! noteCurrentReference: typeID "PRIVATE -- If we support references for type typeID, remember the current byteStream position so we can add the next object to the 'objects' dictionary, and return true. Else return false. This method is here to be overridden by ReferenceStream" ^ false! ! !DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:12'! readFloatString "PRIVATE -- Read the contents of a Float string. This is the slow way to read a Float--via its string rep'n. It's here for compatibility with old data files." ^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))! ! !DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 16:59'! tryToPutReference: anObject typeID: typeID "PRIVATE -- If we support references for type typeID, and if anObject already appears in my output stream, then put a reference to the place where anObject already appears. If we support references for typeID but didn't already put anObject, then associate the current stream position with anObject in case one wants to nextPut: it again. Return true after putting a reference; false if the object still needs to be put. For DataStream this is trivial. ReferenceStream overrides this." ^ false! ! !DataStream methodsFor: 'write and read' stamp: 'yo 12/3/2004 17:07'! writeFloatString: aFloat "PRIVATE -- Write the contents of a Float string. This is the slow way to write a Float--via its string rep'n." self writeByteArray: (aFloat printString)! ! !DataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'! contents ^byteStream contents! ! !DataStream methodsFor: 'other' stamp: 'yo 12/3/2004 17:14'! errorWriteReference: anInteger "PRIVATE -- Raise an error because this case of nextPut:'s perform: shouldn't be called. -- 11/15/92 jhm" self error: 'This should never be called'! ! !DataStream methodsFor: 'other' stamp: 'tk 3/5/2002 09:51'! nextAndClose "Speedy way to grab one object. Only use when we are inside an object binary file. Do not use for the start of a SmartRefStream mixed code-and-object file." | obj | obj _ self next. self close. ^ obj! ! !DataStream methodsFor: 'other' stamp: 'ar 2/24/2001 22:45'! project ^nil! ! !DataStream class methodsFor: 'as yet unclassified' stamp: 'tk 3/7/2001 17:57'! initialize "TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats. nextPut: writes these IDs to the data stream. NOTE: Changing these type ID numbers will invalidate all extant data stream files. Adding new ones is OK. Classes named here have special formats in the file. If such a class has a subclass, it will use type 9 and write correctly. It will just be slow. (Later write the class name in the special format, then subclasses can use the type also.) See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:" "DataStream initialize" | refTypes t | refTypes _ OrderedCollection new. t _ TypeMap _ Dictionary new: 80. "sparse for fast hashing" t at: UndefinedObject put: 1. refTypes add: 0. t at: True put: 2. refTypes add: 0. t at: False put: 3. refTypes add: 0. t at: SmallInteger put: 4. refTypes add: 0. t at: String put: 5. refTypes add: 1. t at: Symbol put: 6. refTypes add: 1. t at: ByteArray put: 7. refTypes add: 1. t at: Array put: 8. refTypes add: 1. "(type ID 9 is for arbitrary instances of any class, cf. typeIDFor:)" refTypes add: 1. "(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)" refTypes add: 0. t at: Bitmap put: 11. refTypes add: 1. t at: Metaclass put: 12. refTypes add: 0. "Type ID 13 is used for HyperSqueak User classes that must be reconstructed." refTypes add: 1. t at: Float put: 14. refTypes add: 1. t at: Rectangle put: 15. refTypes add: 1. "Allow compact Rects." "type ID 16 is an instance with short header. See beginInstance:size:" refTypes add: 1. t at: String put: 17. refTypes add: 1. "new String format, 1 or 4 bytes of length" t at: WordArray put: 18. refTypes add: 1. "bitmap-like" t at: WordArrayForSegment put: 19. refTypes add: 1. "bitmap-like" t at: SoundBuffer put: 20. refTypes add: 1. "And all other word arrays, both 16-bit and 32-bit. See methods in ArrayedCollection. Overridden in SoundBuffer." t at: CompiledMethod put: 21. refTypes add: 1. "special creation method" "t at: put: 22. refTypes add: 0." ReferenceStream refTypes: refTypes. "save it" "For all classes that are like WordArrays, store them the way ColorArray is stored. As bits, and able to change endianness." Smalltalk do: [:cls | cls isInMemory ifTrue: [ cls isBehavior ifTrue: [ cls isPointers not & cls isVariable & cls isWords ifTrue: [ (t includesKey: cls) ifFalse: [t at: cls put: 20]]]]].! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:36'! addExtraItemsToMenu: aMenu forSlotSymbol: slotSym "If the receiver has extra menu items to add to the slot menu, here is its chance to do it"! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:38'! addUserSlotItemsTo: aMenu slotSymbol: slotSym "Optionally add items to the menu that pertain to a user-defined slot of the given symbol" ! ! !DataType methodsFor: 'tiles' stamp: 'sw 1/12/2005 08:35'! addWatcherItemsToMenu: aMenu forGetter: aGetter "Add watcher items to the menu if appropriate, provided the getter is not an odd-ball one for which a watcher makes no sense" (Vocabulary gettersForbiddenFromWatchers includes: aGetter) ifFalse: [aMenu add: 'simple watcher' translated selector: #tearOffUnlabeledWatcherFor: argument: aGetter. aMenu add: 'detailed watcher' translated selector: #tearOffFancyWatcherFor: argument: aGetter. aMenu addLine]! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 02:29'! affordsCoercionToBoolean "Answer true if a tile of this data type, when dropped into a pane that demands a boolean, could plausibly be expanded into a comparison (of the form frog < toad or frog = toad) to provide a boolean expression" ^ true! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 02:53'! comparatorForSampleBoolean "Answer the comparator to use in tile coercions involving the receiver; normally, the equality comparator is used but NumberType overrides" ^ #=! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 13:15'! defaultArgumentTile "Answer a tile to represent the type" ^ 'arg' newTileMorphRepresentative typeColor: self typeColor! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:37'! newReadoutTile "Answer a tile that can serve as a readout for data of this type" ^ StringReadoutTile new typeColor: Color lightGray lighter! ! !DataType methodsFor: 'tiles' stamp: 'sw 1/4/2005 00:45'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" | aTile displayer actualSetter | actualSetter _ setter ifNotNil: [(#(none #nil unused) includes: setter) ifTrue: [nil] ifFalse: [setter]]. aTile _ self newReadoutTile. displayer _ UpdatingStringMorph new getSelector: getter; target: aTarget; growable: true; minimumWidth: 24; putSelector: actualSetter. "Note that when typeSymbol = #number, the #target: call above will have dealt with floatPrecision details" self setFormatForDisplayer: displayer. aTile addMorphBack: displayer. (actualSetter notNil and: [self wantsArrowsOnTiles]) ifTrue: [aTile addArrows]. getter numArgs == 0 ifTrue: [aTile setLiteralInitially: (aTarget perform: getter)]. ^ aTile ! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:33'! wantsArrowsOnTiles "Answer whether this data type wants up/down arrows on tiles representing its values" ^ true! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:11'! wantsAssignmentTileVariants "Answer whether an assignment tile for a variable of this type should show variants to increase-by, decrease-by, multiply-by. NumberType says yes, the rest of us say no" ^ false! ! !DataType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:18'! wantsSuffixArrow "Answer whether a tile showing data of this type would like to have a suffix arrow" ^ false! ! !DataType methodsFor: 'initial value' stamp: 'sw 9/26/2001 12:00'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ 'no value'! ! !DataType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:32'! setFormatForDisplayer: aDisplayer "Set up the displayer to have the right format characteristics" aDisplayer useDefaultFormat. aDisplayer growable: true ! ! !DataType methodsFor: 'color' stamp: 'sw 8/28/2004 20:30'! subduedColorFromTriplet: anRGBTriplet "Currently: as an expedient, simply return a standard system-wide constant; this is used only for the border-color of tiles... Formerly: Answer a subdued color derived from the rgb-triplet to use as a tile color." ^ ScriptingSystem standardTileBorderColor " ^ (Color fromRgbTriplet: anRGBTriplet) mixed: ScriptingSystem colorFudge with: ScriptingSystem uniformTileInteriorColor"! ! !DataType methodsFor: 'queries' stamp: 'mir 7/15/2004 10:34'! representsAType "Answer whether this vocabulary represents an end-user-sensible data type" "^ (self class == DataType) not" "i.e. subclasses yes, myself no" "Assuming this is an abstract class" ^true! ! !DataType commentStamp: 'sw 8/22/2002 15:01' prior: 0! A Vocabulary representing typed data.! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:07'! mmddyyyy "Answer the receiver rendered in standard U.S.A format mm/dd/yyyy. Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example February 1 1996 is 2/1/96" ^ self printFormat: #(2 1 3 $/ 1 1)! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:06'! printFormat: formatArray "Answer a String describing the receiver using the argument formatArray." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream format: formatArray. ^ aStream contents! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:05'! printOn: aStream format: formatArray "Print a description of the receiver on aStream using the format denoted the argument, formatArray: #(item item item sep monthfmt yearfmt twoDigits) items: 1=day 2=month 3=year will appear in the order given, separated by sep which is eaither an ascii code or character. monthFmt: 1=09 2=Sep 3=September yearFmt: 1=1996 2=96 digits: (missing or)1=9 2=09. See the examples in printOn: and mmddyy" | gregorian twoDigits element monthFormat | gregorian _ self dayMonthYearDo: [ :d :m :y | {d. m. y} ]. twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1]. 1 to: 3 do: [ :i | element := formatArray at: i. element = 1 ifTrue: [twoDigits ifTrue: [aStream nextPutAll: (gregorian first asString padded: #left to: 2 with: $0)] ifFalse: [gregorian first printOn: aStream]]. element = 2 ifTrue: [monthFormat := formatArray at: 5. monthFormat = 1 ifTrue: [twoDigits ifTrue: [aStream nextPutAll: (gregorian middle asString padded: #left to: 2 with: $0)] ifFalse: [gregorian middle printOn: aStream]]. monthFormat = 2 ifTrue: [aStream nextPutAll: ((Month nameOfMonth: gregorian middle) copyFrom: 1 to: 3)]. monthFormat = 3 ifTrue: [aStream nextPutAll: (Month nameOfMonth: gregorian middle)]]. element = 3 ifTrue: [(formatArray at: 6) = 1 ifTrue: [gregorian last printOn: aStream] ifFalse: [aStream nextPutAll: ((gregorian last \\ 100) asString padded: #left to: 2 with: $0)]]. i < 3 ifTrue: [(formatArray at: 4) ~= 0 ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]] ! ! !Date methodsFor: 'printing' stamp: 'BP 3/23/2001 12:27'! storeOn: aStream aStream print: self printString; nextPutAll: ' asDate'! ! !Date methodsFor: 'printing' stamp: 'brp 7/27/2003 16:04'! yyyymmdd "Format the date in ISO 8601 standard like '2002-10-22'." ^ self printFormat: #(3 2 1 $- 1 1 2)! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:09'! addDays: dayCount ^ (self asDateAndTime + (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! asSeconds "Answer the seconds since the Squeak epoch: 1 January 1901" ^ start asSeconds! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:08'! leap "Answer whether the receiver's year is a leap year." ^ start isLeapYear ifTrue: [1] ifFalse: [0].! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:30'! previous: dayName "Answer the previous date whose weekday name is dayName." | days | days _ 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7. days = 0 ifTrue: [ days _ 7 ]. ^ self subtractDays: days ! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:09'! subtractDate: aDate "Answer the number of days between self and aDate" ^ (self start - aDate asDateAndTime) days! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 22:05'! subtractDays: dayCount ^ (self asDateAndTime - (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! weekday "Answer the name of the day of the week on which the receiver falls." ^ self dayOfWeekName! ! !Date methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! weekdayIndex "Sunday=1, ... , Saturday=7" ^ self dayOfWeek! ! !Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'! asDate ^ self! ! !Date methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:10'! dayMonthYearDo: aBlock "Supply integers for day, month and year to aBlock and return the result" ^ start dayMonthYearDo: aBlock! ! !Date methodsFor: 'squeak protocol' stamp: 'avi 2/21/2004 18:12'! month ^ self asMonth! ! !Date methodsFor: 'squeak protocol' stamp: 'avi 2/29/2004 13:10'! monthIndex ^ super month! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:36'! asGregorian "Return an array of integers #(dd mm yyyy)" ^ self deprecated: 'Use #dayMonthYearDo:'; dayMonthYearDo: [ :d :m :y | { d. m. y } ] ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:32'! asJulianDayNumber ^ self deprecated: 'Use #julianDayNumber'; julianDayNumber! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:36'! day: dayInteger year: yearInteger ^ self deprecated: 'Obsolete' ! ! !Date methodsFor: 'deprecated' stamp: 'md 10/17/2004 16:13'! daylightSavingsInEffect "Return true if DST is observed at or after 2am on this day" self deprecated: 'Deprecated'. self dayMonthYearDo: [ :day :month :year | (month < 4 or: [month > 10]) ifTrue: [^ false]. "False November through March" (month > 4 and: [month < 10]) ifTrue: [^ true]. "True May through September" month = 4 ifTrue: ["It's April -- true on first Sunday or later" day >= 7 ifTrue: [^ true]. "Must be after" ^ day > (self weekdayIndex \\ 7)] ifFalse: ["It's October -- false on last Sunday or later" day <= 24 ifTrue: [^ true]. "Must be before" ^ day <= (24 + (self weekdayIndex \\ 7))]]! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:39'! daylightSavingsInEffectAtStandardHour: hour "Return true if DST is observed at this very hour (standard time)" "Note: this *should* be the kernel method, and daylightSavingsInEffect should simply be self daylightSavingsInEffectAtHour: 3" self deprecated: 'Deprecated'. self daylightSavingsInEffect ifTrue: [^ (self addDays: -1) daylightSavingsInEffect or: [hour >= 2]] ifFalse: [^ (self addDays: -1) daylightSavingsInEffect and: [hour < 1]]! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:37'! firstDayOfMonthIndex: monthIndex ^ self deprecated: 'Obsolete' ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:41'! julianDayNumber: anInteger "Set the number of days elapsed since midnight GMT on January 1st, 4713 B.C." self deprecated: 'Obsolete'. ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:34'! mmddyy "Please use mmddyyyy instead, so dates in 2000 will be unambiguous" ^ self deprecated: 'Use #mmddyyyy'; printFormat: #(2 1 3 $/ 1 2) ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:46'! uniqueDateStringBetween: aStart and: anEnd "Return a String, with just enough information to distinguish it from other dates in the range." "later, be more sophisticated" self deprecated: 'Deprecated'. aStart year + 1 >= anEnd year ifFalse: [^ self printFormat: #(1 2 3 $ 3 1)]. "full" aStart week next >= anEnd week ifFalse: [^ self printFormat: #(2 1 9 $ 3 1)]. "May 6" ^ self weekday ! ! !Date methodsFor: 'deprecated' stamp: 'brp 8/5/2003 18:31'! week ^ self deprecated: 'Use #asWeek'; asWeek! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:49'! addMonths: monthCount ^ Date newDay: self dayOfMonth month: self month + monthCount - 1 \\ 12 + 1 year: self year + (monthCount + self month - 1 // 12)! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onNextMonth ^ self addMonths: 1 ! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onPreviousMonth ^ self addMonths: -1 ! ! !Date commentStamp: '' prior: 0! Instances of Date are Timespans with duration of 1 day. Their default creation assumes a start of midnight in the local time zone.! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'! dateAndTimeNow "Answer an Array whose with Date today and Time now." ^ Time dateAndTimeNow! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:35'! dayOfWeek: dayName ^ Week indexOfDay: dayName! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:59'! daysInMonth: monthName forYear: yearInteger ^ Month daysInMonth: monthName forYear: yearInteger. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:53'! daysInYear: yearInteger ^ Year daysInYear: yearInteger.! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 1/16/2004 14:35'! firstWeekdayOfMonth: month year: year "Answer the weekday index of the first day in in the ." ^ (self newDay: 1 month: month year: year) weekdayIndex ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! fromDays: dayCount "Days since 1 January 1901" ^ self julianDayNumber: dayCount + SqueakEpoch! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'! fromSeconds: seconds "Answer an instance of me which is 'seconds' seconds after January 1, 1901." ^ self fromDays: ((Duration seconds: seconds) days)! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:39'! indexOfMonth: aMonthName ^ Month indexOfMonth: aMonthName. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:56'! leapYear: yearInteger ^ Year leapYear: yearInteger! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:37'! nameOfDay: dayIndex ^ Week nameOfDay: dayIndex ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 13:40'! nameOfMonth: anIndex ^ Month nameOfMonth: anIndex. ! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:02'! newDay: day month: month year: year ^ self year: year month: month day: day! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! newDay: dayCount year: yearInteger ^ self year: yearInteger day: dayCount! ! !Date class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:01'! today ^ self current! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:13'! absoluteDaysToYear: gregorianYear self deprecated: 'Deprecated'! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:14'! fromJulianDayNumber: aJulianDayNumber self deprecated: 'Deprecated'; julianDayNumber: aJulianDayNumber! ! !Date class methodsFor: 'deprecated' stamp: 'brp 8/4/2003 22:15'! yearAndDaysFromDays: days into: aTwoArgBlock self deprecated: 'Deprecated'! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:03'! fromString: aString "Answer an instance of created from a string with format dd.mm.yyyy." ^ self readFrom: aString readStream. ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 18:25'! julianDayNumber: aJulianDayNumber ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 09:21'! readFrom: aStream "Read a Date from the stream in any of the forms: (5 April 1982; 5-APR-82) (April 5, 1982) (4/5/82) (5APR82)" | day month year | aStream peek isDigit ifTrue: [day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. aStream peek isLetter ifTrue: ["number/name... or name..." month := WriteStream on: (String new: 10). [aStream peek isLetter] whileTrue: [month nextPut: aStream next]. month := month contents. day isNil ifTrue: ["name/number..." [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. day := Integer readFrom: aStream]] ifFalse: ["number/number..." month := Month nameOfMonth: day. day := Integer readFrom: aStream]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. year := Integer readFrom: aStream. year < 10 ifTrue: [year := 2000 + year] ifFalse: [ year < 1900 ifTrue: [ year := 1900 + year]]. ^ self year: year month: month day: day! ! !Date class methodsFor: 'squeak protocol' stamp: 'BP 3/23/2001 12:36'! starting: aDateAndTime ^super starting: (aDateAndTime midnight) duration: (Duration days: 1) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! tomorrow ^ self today next! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:03'! year: year day: dayOfYear ^ self starting: (DateAndTime year: year day: dayOfYear) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 22:02'! year: year month: month day: day ^ self starting: (DateAndTime year: year month: month day: day) ! ! !Date class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 18:09'! yesterday ^ self today previous! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/9/2005 08:45'! + operand "operand conforms to protocol Duration" | ticks | ticks _ self ticks + (operand asDuration ticks) . ^ self class basicNew ticks: ticks offset: self offset; yourself. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 05:39'! - operand "operand conforms to protocol DateAndTime or protocol Duration" ^ (operand respondsTo: #asDateAndTime) ifTrue: [ | lticks rticks | lticks _ self asLocal ticks. rticks _ operand asDateAndTime asLocal ticks. Duration seconds: (SecondsInDay *(lticks first - rticks first)) + (lticks second - rticks second) nanoSeconds: (lticks third - rticks third) ] ifFalse: [ self + (operand negated) ]. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 09:09'! < comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | lticks rticks comparandAsDateAndTime | comparandAsDateAndTime := comparand asDateAndTime. offset = comparandAsDateAndTime offset ifTrue: [lticks := self ticks. rticks := comparandAsDateAndTime ticks] ifFalse: [lticks := self asUTC ticks. rticks := comparandAsDateAndTime asUTC ticks]. ^ lticks first < rticks first or: [lticks first > rticks first ifTrue: [false] ifFalse: [lticks second < rticks second or: [lticks second > rticks second ifTrue: [false] ifFalse: [lticks third < rticks third]]]] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 7/28/2004 16:14'! = comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | comparandAsDateAndTime | self == comparand ifTrue: [^ true]. [comparandAsDateAndTime := comparand asDateAndTime] on: MessageNotUnderstood do: [^ false]. ^ self offset = comparandAsDateAndTime offset ifTrue: [self hasEqualTicks: comparandAsDateAndTime ] ifFalse: [self asUTC ticks = comparandAsDateAndTime asUTC ticks] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 13:11'! asLocal ^ (self offset = self class localOffset) ifTrue: [self] ifFalse: [self utcOffset: self class localOffset] ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 13:12'! asUTC ^ self utcOffset: 0! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:03'! dayOfMonth "Answer which day of the month is represented by the receiver." ^ self dayMonthYearDo: [ :d :m :y | d ]! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 12:25'! dayOfWeek "Sunday=1, ... , Saturday=7" ^ (jdn + 1 rem: 7) + 1! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:34'! dayOfWeekAbbreviation ^ self dayOfWeekName copyFrom: 1 to: 3! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:28'! dayOfWeekName ^ Week nameOfDay: self dayOfWeek ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! dayOfYear ^ jdn - (Year year: self year) start julianDayNumber + 1 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 15:49'! hash ^ self asUTC ticks hash ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! hour ^ self hour24 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 18:46'! hour12 "Answer an between 1 and 12, inclusive, representing the hour of the day in the 12-hour clock of the local time of the receiver." ^ self hour24 - 1 \\ 12 + 1! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! hour24 ^ (Duration seconds: seconds) hours ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:29'! isLeapYear ^ Year isLeapYear: self year. ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/24/2003 11:03'! meridianAbbreviation ^ self asTime meridianAbbreviation! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! minute ^ (Duration seconds: seconds) minutes ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'! month ^ self dayMonthYearDo: [ :d :m :y | m ].! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! monthAbbreviation ^ self monthName copyFrom: 1 to: 3 ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! monthName ^ Month nameOfMonth: self month ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:30'! offset ^ offset ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:09'! offset: anOffset "Answer a equivalent to the receiver but with its local time being offset from UTC by offset." ^ self class basicNew ticks: self ticks offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:31'! second ^ (Duration seconds: seconds) seconds ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'! timeZoneAbbreviation ^ self class localTimeZone abbreviation ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 9/4/2003 06:42'! timeZoneName ^ self class localTimeZone name ! ! !DateAndTime methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:05'! year ^ self dayMonthYearDo: [ :d :m :y | y ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 23:56'! asDate ^ Date starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:46'! asDateAndTime ^ self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asDuration "Answer the duration since midnight" ^ Duration seconds: seconds nanoSeconds: nanos ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asMonth ^ Month starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:45'! asNanoSeconds "Answer the number of nanoseconds since midnight" ^ self asDuration asNanoSeconds ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:00'! asTime ^ Time seconds: seconds nanoSeconds: nanos! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 00:02'! asTimeStamp ^ self as: TimeStamp! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asWeek ^ Week starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:47'! asYear ^ Year starting: self ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:47'! dayMonthYearDo: aBlock "Evaluation the block with three arguments: day month, year." | l n i j dd mm yyyy | l := jdn + 68569. n := 4 * l // 146097. l := l - (146097 * n + 3 // 4). i := 4000 * (l + 1) // 1461001. l := l - (1461 * i // 4) + 31. j := 80 * l // 2447. dd := l - (2447 * j // 80). l := j // 11. mm := j + 2 - (12 * l). yyyy := 100 * (n - 49) + i + l. ^ aBlock value: dd value: mm value: yyyy.! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! duration ^ Duration zero ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! julianDayNumber ^ jdn ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:49'! middleOf: aDuration "Return a Timespan where the receiver is the middle of the Duration" | duration | duration _ aDuration asDuration. ^ Timespan starting: (self - (duration / 2)) duration: duration. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:48'! midnight "Answer a DateAndTime starting at midnight local time" ^ self dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:50'! nanoSecond ^ nanos ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:49'! noon "Answer a DateAndTime starting at noon" ^ self dayMonthYearDo: [ :d :m :y | self class year: y month: m day: d hour: 12 minute: 0 second: 0 ]! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:03'! printHMSOn: aStream "Print just hh:mm:ss" aStream nextPutAll: (self hour asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self minute asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (self second asString padded: #left to: 2 with: $0). ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:38'! printOn: aStream "Print as per ISO 8601 sections 5.3.3 and 5.4.1. Prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years)" ^self printOn: aStream withLeadingSpace: false ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'dtl 10/31/2004 01:20'! printOn: aStream withLeadingSpace: printLeadingSpaceToo "Print as per ISO 8601 sections 5.3.3 and 5.4.1. If printLeadingSpaceToo is false, prints either: 'YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) If printLeadingSpaceToo is true, prints either: ' YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for positive years) or '-YYYY-MM-DDThh:mm:ss.s+ZZ:zz:z' (for negative years) " self printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo. aStream nextPut: $T. self printHMSOn: aStream. self nanoSecond ~= 0 ifTrue: [ | z ps | ps := self nanoSecond printString padded: #left to: 9 with: $0. z := ps findLast: [ :c | c asciiValue > $0 asciiValue ]. (z > 0) ifTrue: [aStream nextPut: $.]. ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. aStream nextPut: (offset positive ifTrue: [$+] ifFalse: [$-]); nextPutAll: (offset hours abs asString padded: #left to: 2 with: $0); nextPut: $:; nextPutAll: (offset minutes abs asString padded: #left to: 2 with: $0). offset seconds = 0 ifFalse: [ aStream nextPut: $:; nextPutAll: (offset seconds abs truncated asString) ]. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! printYMDOn: aStream "Print just YYYY-MM-DD part. If the year is negative, prints out '-YYYY-MM-DD'." ^self printYMDOn: aStream withLeadingSpace: false. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'nk 3/12/2004 10:29'! printYMDOn: aStream withLeadingSpace: printLeadingSpaceToo "Print just the year, month, and day on aStream. If printLeadingSpaceToo is true, then print as: ' YYYY-MM-DD' (if the year is positive) or '-YYYY-MM-DD' (if the year is negative) otherwise print as: 'YYYY-MM-DD' or '-YYYY-MM-DD' " | year month day | self dayMonthYearDo: [ :d :m :y | year := y. month := m. day := d ]. year negative ifTrue: [ aStream nextPut: $- ] ifFalse: [ printLeadingSpaceToo ifTrue: [ aStream space ]]. aStream nextPutAll: (year abs asString padded: #left to: 4 with: $0); nextPut: $-; nextPutAll: (month asString padded: #left to: 2 with: $0); nextPut: $-; nextPutAll: (day asString padded: #left to: 2 with: $0) ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:50'! to: anEnd "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ Timespan starting: self ending: (anEnd asDateAndTime). ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:57'! to: anEnd by: aDuration "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (Schedule starting: self ending: (anEnd asDateAndTime)) schedule: (Array with: aDuration asDuration); yourself. ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:01'! to: anEnd by: aDuration do: aBlock "Answer a Timespan. anEnd conforms to protocol DateAndTime or protocol Timespan" ^ (self to: anEnd by: aDuration) scheduleDo: aBlock ! ! !DateAndTime methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:37'! utcOffset: anOffset "Answer a equivalent to the receiver but offset from UTC by anOffset" | equiv | equiv _ self + (anOffset asDuration - self offset). ^ equiv ticks: (equiv ticks) offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 21:03'! asSeconds "Return the number of seconds since the Squeak epoch" ^ (self - (self class epoch)) asSeconds ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 17:53'! day ^ self dayOfYear! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! daysInMonth "Answer the number of days in the month represented by the receiver." ^ self asMonth daysInMonth ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:48'! daysInYear "Answer the number of days in the year represented by the receiver." ^ self asYear daysInYear ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^ self daysInYear - self dayOfYear ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 15:44'! firstDayOfMonth ^ self asMonth start day! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:30'! hours ^ self hour! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 1/7/2004 15:45'! minutes ^ self minute! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 07:50'! monthIndex ^ self month ! ! !DateAndTime methodsFor: 'smalltalk-80' stamp: 'brp 7/1/2003 18:31'! seconds ^ self second! ! !DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:22'! hasEqualTicks: aDateAndTime ^ (jdn = aDateAndTime julianDayNumber) and: [ (seconds = aDateAndTime secondsSinceMidnight) and: [ nanos = aDateAndTime nanoSecond ] ] ! ! !DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:20'! secondsSinceMidnight ^ seconds! ! !DateAndTime methodsFor: 'private' stamp: 'brp 8/23/2003 15:45'! ticks "Private - answer an array with our instance variables. Assumed to be UTC " ^ Array with: jdn with: seconds with: nanos .! ! !DateAndTime methodsFor: 'private' stamp: 'nk 3/30/2004 09:38'! ticks: ticks offset: utcOffset "ticks is {julianDayNumber. secondCount. nanoSeconds}" | normalize | normalize := [ :i :base | | tick div quo rem | tick := ticks at: i. div := tick digitDiv: base neg: tick negative. quo := div first normalize. rem := div second normalize. rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ]. ticks at: (i-1) put: ((ticks at: i-1) + quo). ticks at: i put: rem ]. normalize value: 3 value: NanosInSecond. normalize value: 2 value: SecondsInDay. jdn _ ticks first. seconds _ ticks second. nanos := ticks third. offset := utcOffset. ! ! !DateAndTime commentStamp: 'brp 5/13/2003 08:07' prior: 0! I represent a point in UTC time as defined by ISO 8601. I have zero duration. My implementation uses three SmallIntegers and a Duration: jdn - julian day number. seconds - number of seconds since midnight. nanos - the number of nanoseconds since the second. offset - duration from UTC. The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:32'! clockPrecision "One nanosecond precision" ^ Duration nanoSeconds: 1 ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'avi 2/21/2004 19:03'! now ^ self basicNew ticks: (Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: self totalSeconds nanoSeconds: 0) ticks offset: self localOffset; yourself ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:25'! year: year day: dayOfYear hour: hour minute: minute second: second ^ self year: year day: dayOfYear hour: hour minute: minute second: second offset: self localOffset. ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 7/27/2003 15:28'! year: year day: dayOfYear hour: hour minute: minute second: second offset: offset "Return a DataAndTime" | y d | y _ self year: year month: 1 day: 1 hour: hour minute: minute second: second nanoSecond: 0 offset: offset. d _ Duration days: (dayOfYear - 1). ^ y + d! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 21:00'! year: year month: month day: day hour: hour minute: minute second: second "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: second offset: self localOffset ! ! !DateAndTime class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:36'! year: year month: month day: day hour: hour minute: minute second: second offset: offset ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: 0 offset: offset ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'! current ^ self now ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 16:12'! date: aDate time: aTime ^ self year: aDate year day: aDate dayOfYear hour: aTime hour minute: aTime minute second: aTime second ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp` 8/24/2003 19:11'! epoch "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ self julianDayNumber: SqueakEpoch ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 07:36'! fromString: aString ^ self readFrom: (ReadStream on: aString) ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 21:08'! julianDayNumber: aJulianDayNumber ^ self basicNew ticks: aJulianDayNumber days ticks offset: self localOffset; yourself ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:40'! localOffset "Answer the duration we are offset from UTC" ^ self localTimeZone offset ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 9/4/2003 06:39'! localTimeZone "Answer the local time zone" ^ LocalTimeZone ifNil: [ LocalTimeZone _ TimeZone default ] ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'nk 3/30/2004 09:53'! localTimeZone: aTimeZone "Set the local time zone" " DateAndTime localTimeZone: (TimeZone offset: 0 hours name: 'Universal Time' abbreviation: 'UTC'). DateAndTime localTimeZone: (TimeZone offset: -8 hours name: 'Pacific Standard Time' abbreviation: 'PST'). " LocalTimeZone := aTimeZone ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! midnight ^ self now midnight ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:57'! new "Answer a DateAndTime representing the Squeak epoch: 1 January 1901" ^ self epoch ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! noon ^ self now noon! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:58'! readFrom: aStream | bc year month day hour minute second nanos offset buffer ch | aStream peek = $- ifTrue: [ aStream next. bc _ -1] ifFalse: [bc _ 1]. year _ (aStream upTo: $-) asInteger * bc. month _ (aStream upTo: $-) asInteger. day _ (aStream upTo: $T) asInteger. hour _ (aStream upTo: $:) asInteger. buffer _ '00:'. ch _ nil. minute _ WriteStream on: buffer. [ aStream atEnd | (ch = $:) | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ minute nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $: ]. minute _ ((ReadStream on: buffer) upTo: ch) asInteger. buffer _ '00.'. second _ WriteStream on: buffer. [ aStream atEnd | (ch = $.) | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ second nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $. ]. second _ ((ReadStream on: buffer) upTo: ch) asInteger. buffer _ '00000000+'. nanos _ WriteStream on: buffer. [ aStream atEnd | (ch = $+) | (ch = $-) ] whileFalse: [ ch _ nanos nextPut: aStream next. ]. (ch isNil or: [ch isDigit]) ifTrue: [ ch _ $+ ]. nanos _ ((ReadStream on: buffer) upTo: ch) asInteger. aStream atEnd ifTrue: [ offset _ self localOffset ] ifFalse: [offset _ Duration fromString: (ch asString, '0:', aStream upToEnd). (offset = self localOffset) ifTrue: [ offset _ self localOffset ]]. ^ self year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanos offset: offset. " '-1199-01-05T20:33:14.321-05:00' asDateAndTime ' 2002-05-16T17:20:45.00000001+01:01' asDateAndTime ' 2002-05-16T17:20:45.00000001' asDateAndTime ' 2002-05-16T17:20' asDateAndTime ' 2002-05-16T17:20:45' asDateAndTime ' 2002-05-16T17:20:45+01:57' asDateAndTime ' 2002-05-16T17:20:45-02:34' asDateAndTime ' 2002-05-16T17:20:45+00:00' asDateAndTime ' 1997-04-26T01:02:03+01:02:3' asDateAndTime " ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 17:09'! today ^ self midnight ! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'! tomorrow ^ self today asDate next asDateAndTime! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:53'! year: year day: dayOfYear "Return a DateAndTime" ^ self year: year day: dayOfYear hour: 0 minute: 0 second: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'! year: year month: month day: day "Return a DateAndTime, midnight local time" ^ self year: year month: month day: day hour: 0 minute: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 20:54'! year: year month: month day: day hour: hour minute: minute "Return a DateAndTime" ^ self year: year month: month day: day hour: hour minute: minute second: 0! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'bvs 9/29/2004 16:43'! year: year month: month day: day hour: hour minute: minute second: second nanoSecond: nanoCount offset: offset "Return a DateAndTime" | monthIndex daysInMonth p q r s julianDayNumber since | monthIndex _ month isInteger ifTrue: [month] ifFalse: [Month indexOfMonth: month]. daysInMonth _ Month daysInMonth: monthIndex forYear: year. day < 1 ifTrue: [self error: 'day may not be zero or negative']. day > daysInMonth ifTrue: [self error: 'day is after month ends']. p _ (monthIndex - 14) quo: 12. q _ year + 4800 + p. r _ monthIndex - 2 - (12 * p). s _ (year + 4900 + p) quo: 100. julianDayNumber _ ( (1461 * q) quo: 4 ) + ( (367 * r) quo: 12 ) - ( (3 * s) quo: 4 ) + ( day - 32075 ). since _ Duration days: julianDayNumber hours: hour minutes: minute seconds: second nanoSeconds: nanoCount. ^ self basicNew ticks: since ticks offset: offset; yourself.! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'brp 8/24/2003 12:19'! yesterday ^ self today asDate previous asDateAndTime ! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp` 8/24/2003 19:09'! fromSeconds: seconds "Answer a DateAndTime since the Squeak epoch: 1 January 1901" | since | since _ Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: seconds. ^ self basicNew ticks: since ticks offset: self localOffset; yourself. ! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:00'! millisecondClockValue ^ Time millisecondClockValue! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'brp 8/24/2003 00:01'! totalSeconds ^ Time totalSeconds! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1901' asDate. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:34'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:06'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:27'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'January' year: 1901). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:01'! testAsSeconds self assert: aDateAndTime asSeconds = 0 asDuration asSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:32'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:51'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = TimeStamp new. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:07'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:43'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:43'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1901' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:46'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:08'! testDayMonthYearDo |iterations| iterations := 0. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | iterations := iterations + 1]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 1901. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 1. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 15:45'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:47'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 3. self assert: aDateAndTime dayOfWeekAbbreviation = 'Tue'. self assert: aDateAndTime dayOfWeekName = 'Tuesday'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:24'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! testEpoch self assert: aDateAndTime = '1901-01-01T00:00:00+00:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:44'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:26'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00'). self assert: aDateAndTime = (DateAndTime fromString: ' 1901-01-01T00:00:00+00:00'). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testHash self assert: aDateAndTime hash = DateAndTime new hash. self assert: aDateAndTime hash = 199296261 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:59'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 0. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:21'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:18'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2415386). self assert: aDateAndTime julianDayNumber = 2415386.! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:20'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:40'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:37'! testMiddleOf self assert: (aDateAndTime middleOf: '2:00:00:00' asDuration) = (Timespan starting: '12-31-1900' asDate duration: 2 days). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:39'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:03'! testMinus self assert: aDateAndTime - aDateAndTime = '0:00:00:00' asDuration. self assert: aDateAndTime - '0:00:00:00' asDuration = aDateAndTime. self assert: aDateAndTime - aDuration = (DateAndTime year: 1900 month: 12 day: 30 hour: 21 minute: 56 second: 55 nanoSecond: 999999995 offset: 0 hours ). " I believe this Failure is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:35'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:41'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:46'! testMonth self assert: aDateAndTime month = 1. self assert: aDateAndTime monthAbbreviation = 'Jan'. self assert: aDateAndTime monthName = 'January'. self assert: aDateAndTime monthIndex = 1.! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:47'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:27'! testNew self assert: aDateAndTime = (DateAndTime new). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 19:49'! testNoon self assert: aDateAndTime noon = '1901-01-01T12:00:00+00:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:41'! testOffset self assert: aDateAndTime offset = '0:00:00:00' asDuration. self assert: (aDateAndTime offset: '0:12:00:00') = '1901-01-01T00:00:00+12:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 11:03'! testPlus self assert: aDateAndTime + '0:00:00:00' = aDateAndTime. self assert: aDateAndTime + 0 = aDateAndTime. self assert: aDateAndTime + aDuration = (DateAndTime year: 1901 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 10:16'! testPrintOn | cs rw | cs := ReadStream on: '1901-01-01T00:00:00+00:00'. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := ReadStream on: 'a TimeZone(ETZ)'. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:25'! testTicks self assert: aDateAndTime ticks = (DateAndTime julianDayNumber: 2415386) ticks. self assert: aDateAndTime ticks = #(2415386 0 0)! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:31'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:42'! testTo self assert: (aDateAndTime to: aDateAndTime) = (DateAndTime new to: DateAndTime new) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:43'! testToBy self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days) = (DateAndTime new to: DateAndTime new + 10 days by: 5 days ) "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:53'! testToByDo "self assert: (aDateAndTime to: aDateAndTime + 10 days by: 5 days do: []) = " "MessageNotUnderstood: UndefinedObject>>starting:ending: where UndefinedObject is Timespan "! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:35'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:45'! testTommorrow self assert: (DateAndTime today + 24 hours) = (DateAndTime tomorrow). self deny: aDateAndTime = (DateAndTime tomorrow). "MessageNotUnderstood: Date class>>starting:"! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:58'! testUtcOffset self assert: (aDateAndTime utcOffset: '0:12:00:00') = '1901-01-01T12:00:00+12:00'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 21:00'! testYear self assert: aDateAndTime year = 1901. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:30'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1901 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:23'! testYearMonthDayHourMinuteSecondNanosSecondOffset self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset:0 hours ). self assert: ((DateAndTime year: 1 month: 1 day: 1 hour: 0 minute: 0 second: 0 nanoSecond: 0 offset: 0 hours ) + (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) ) = (DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 0 hours ) " I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)"" I believe this is a bug in the nanosecond part of (DateAndTime >> year:month:day:hour:minute:second:nanoSecond:offset:)" ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:47'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'! testtimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 10:58'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. aDateAndTime := DateAndTime localTimeZone: TimeZone default; epoch. aTimeZone := TimeZone offset: (Duration minutes: 135) name: 'Epoch Test Time Zone' abbreviation: 'ETZ'. aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DateAndTimeEpochTest methodsFor: 'running' stamp: 'tlk 1/2/2004 11:04'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27' prior: 0! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. The other Chronology sunit test cases are: DateTestCase DateAndTimeLeapTestCase, DurationTestCase, ScheduleTestCase TimeStampTestCase TimespanDoTestCase, TimespanDoSpanAYearTestCase, TimespanTestCase, YearMonthWeekTestCase. These tests attempt to exercise all public and private methods. Except, they do not explicitly depreciated methods. tlk My fixtures are: aDateAndTime = January 01, 1901 midnight (the start of the Squeak epoch) with localTimeZone = Grenwhich Meridian (local offset = 0 hours) aDuration = 1 day, 2 hours, 3, minutes, 4 seconds and 5 nano seconds. aTimeZone = 'Epoch Test Time Zone', 'ETZ' , offset: 12 hours, 15 minutes. ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! testAsDate self assert: aDateAndTime asDate = 'February 29, 2004' asDate. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:55'! testAsDuration self assert: aDateAndTime asDuration = aDuration ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:00'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime utcOffset: aDateAndTime class localOffset) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:24'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'February' year: 2004). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = aDuration asNanoSeconds. self assert: aDateAndTime asNanoSeconds = 48780000000000 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:05'! testAsSeconds self assert: aDuration asSeconds = 48780. self assert: aDateAndTime asSeconds = 3255507180 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:26'! testAsTime self assert: aDateAndTime asTime = (Time hour: 13 minute: 33 second: 0) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:31'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = ((TimeStamp readFrom: '2-29-2004 1:33 pm' readStream) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:30'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '02-29-2004' asDate). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:36'! testAsYear self assert: aDateAndTime asYear = (Year starting: '02-29-2004' asDate). self deny: aDateAndTime asYear = (Year starting: '01-01-2004' asDate) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:23'! testDay self assert: aDateAndTime day = 60. self deny: aDateAndTime day = 29 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:16'! testDayMonthYearDo self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachYear]) = 2004. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachMonth]) = 2. self assert: (aDateAndTime dayMonthYearDo: [:eachDay :eachMonth :eachYear | eachDay]) = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 22:17'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:34'! testDayOfWeek self assert: aDateAndTime dayOfWeek = 1. self assert: aDateAndTime dayOfWeekAbbreviation = 'Sun'. self assert: aDateAndTime dayOfWeekName = 'Sunday'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:59'! testDayOfYear self assert: aDateAndTime dayOfYear = 60. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInMonth self assert: aDateAndTime daysInMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 306. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:38'! testFirstDayOfMonth self deny: aDateAndTime firstDayOfMonth = 1. self assert: aDateAndTime firstDayOfMonth = 32 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:43'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00'). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testHash self assert: aDateAndTime hash = 29855404 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:48'! testHour self assert: aDateAndTime hour = aDateAndTime hour24. self assert: aDateAndTime hour = 13. self assert: aDateAndTime hour = aDateAndTime hours ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 3/12/2004 15:19'! testHour12 self assert: aDateAndTime hour12 = 1. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:42'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'PM'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:12'! testMiddleOf self assert: (aDateAndTime middleOf: aDuration) = (Timespan starting: (DateAndTime year: 2004 month: 2 day: 29 hour: 6 minute: 46 second: 30 offset: 2 hours) duration: (Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 )) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:57'! testMidnight self assert: aDateAndTime midnight = '2004-02-29T00:00:00+00:00'. self deny: aDateAndTime midnight = '2004-02-29T00:00:00+02:00' ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:00'! testMinute self assert: aDateAndTime minute = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:44'! testMinutes self assert: aDateAndTime minutes = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:02'! testMonth self assert: aDateAndTime month = 2. self assert: aDateAndTime monthAbbreviation = 'Feb'. self assert: aDateAndTime monthName = 'February'. self assert: aDateAndTime monthIndex = 2.! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:03'! testNoon self assert: aDateAndTime noon = '2004-02-29T12:00:00+00:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:07'! testOffset self assert: aDateAndTime offset = '0:02:00:00' asDuration. self assert: (aDateAndTime offset: '0:12:00:00') = '2004-02-29T13:33:00+12:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:27'! testPrintOn | cs rw | cs := ReadStream on: '2004-02-29T13:33:00+02:00'. rw := ReadWriteStream on: ''. aDateAndTime printOn: rw. self assert: rw contents = cs contents. cs := ReadStream on: 'a TimeZone(UTC)'. rw := ReadWriteStream on: ''. aTimeZone printOn: rw. self assert: rw contents = cs contents ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:12'! testTicks self assert: aDateAndTime ticks = ((DateAndTime julianDayNumber: 2453065) + 48780 seconds) ticks. self assert: aDateAndTime ticks = #(2453065 48780 0)! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:52'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2453065 48780 0) offset: DateAndTime localOffset). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:51'! testUtcOffset self assert: (aDateAndTime utcOffset: '0:02:00:00') = '2004-02-29T13:33:00+02:00'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:17'! testYear self assert: aDateAndTime year = 2004. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:21'! testYearDayHourMinuteSecond self assert: aDateAndTime = ((DateAndTime year: 2004 day: 60 hour: 13 minute: 33 second: 0) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:23'! testYearMonthDayHourMinuteSecond self assert: aDateAndTime = ((DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0) offset: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'nk 3/12/2004 11:26'! testtimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'nk 3/12/2004 11:00'! setUp localTimeZoneToRestore := DateAndTime localTimeZone. DateAndTime localTimeZone: TimeZone default. aDateAndTime := (DateAndTime year: 2004 month: 2 day: 29 hour: 13 minute: 33 second: 0 offset: 2 hours). aTimeZone := TimeZone default. aDuration := Duration days: 0 hours: 13 minutes: 33 seconds: 0 nanoSeconds: 0 ! ! !DateAndTimeLeapTest methodsFor: 'running' stamp: 'tlk 1/2/2004 21:30'! tearDown DateAndTime localTimeZone: localTimeZoneToRestore. "wish I could remove the time zones I added earlier, tut there is no method for that" ! ! !DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54' prior: 0! I represent one of several Sunit test Cases intentended to provide complete coverage for the Chronology set of classes as part of the external testing. tlk. My fixtures are: aDateAndTime = February 29, 2004 1:33 PM with offset: 2 hours aDuration = 15 days, 14 hours, 13 minutes, 12 seconds and 11 nano seconds. aTimeZone = Grenwhich Meridian (local offset = 0 hours) ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 17:00'! testArithmeticAcrossDateBoundary | t1 t2 | t1 _ '2004-01-07T11:55:00+00:00' asDateAndTime. t2 _ t1 - ( (42900+1) seconds). self assert: t2 = ('2004-01-06T23:59:59+00:00' asDateAndTime) ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:00'! testDateTimeDenotation1 "DateAndTimeTest new testDateTimeDenotation1" " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests the correct interpretation of the DateAndTime denotation. " | twoPmInLondon twoPmUTCInLocalTimeOfDetroit nineAmInDetroit | twoPmInLondon := DateAndTime year: 2004 month: 11 day: 2 hour: 14 minute: 0 second: 0 offset: 0 hours. twoPmUTCInLocalTimeOfDetroit _ twoPmInLondon utcOffset: -5 hours. nineAmInDetroit _ '2004-11-02T09:00:00-05:00' asDateAndTime. self assert: twoPmUTCInLocalTimeOfDetroit = nineAmInDetroit. ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/7/2004 13:01'! testDateTimeDenotation2 "DateAndTimeTest new testDateTimeDenotation2" " Moscow is 3 hours ahead UTC, this offset to UTC is therefore positive. This example tests the correct interpretation of the DateAndTime denotation. " | lateEveningInLondon lateEveningInLocalTimeOfMoscow localMoscowTimeFromDenotation | lateEveningInLondon := DateAndTime year: 2004 month: 11 day: 30 hour: 23 minute: 30 second: 0 offset: 0 hours. lateEveningInLocalTimeOfMoscow _ lateEveningInLondon utcOffset: 3 hours. localMoscowTimeFromDenotation _ '2004-12-01T02:30:00+03:00' asDateAndTime. self assert: lateEveningInLocalTimeOfMoscow = localMoscowTimeFromDenotation. ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:22'! testErrorWhenDayIsAfterMonthEnd self should: [DateAndTime year: 2004 month: 2 day: 30] raise: Error. self shouldnt: [DateAndTime year: 2004 month: 2 day: 29] raise: Error. ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'bvs 9/29/2004 16:29'! testErrorWhenDayIsBeforeMonthStart self should: [DateAndTime year: 2004 month: 2 day: -1] raise: Error. self should: [DateAndTime year: 2004 month: 2 day: 0] raise: Error. self shouldnt: [DateAndTime year: 2004 month: 2 day: 1] raise: Error. ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:37'! testInstanceCreation | t | t _ DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t julianDayNumber = 1721427); assert: (t offset = 6 hours); assert: (t hour = 2); assert: (t minute = 3); assert: (t second = 4); assert: (t nanoSecond = 5). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'nk 3/12/2004 11:06'! testMonotonicity | t1 t2 t3 t4 | t1 := DateAndTime now. t2 := DateAndTime now. (Delay forMilliseconds: 1000) wait. t3 := DateAndTime now. t4 := DateAndTime now. self assert: ( t1 <= t2); assert: ( t2 < t3); assert: ( t3 <= t4). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'dtl 11/5/2004 05:45'! testPrintString "(self new setTestSelector: #testPrintString) debug" | dt | dt _DateAndTime year: 2004 month: 11 day: 2 hour: 14 minute: 3 second: 5 nanoSecond: 12345 offset: (Duration seconds: (5 * 3600)). self assert: dt printString = '2004-11-02T14:03:05.000012345+05:00' ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 15:43'! testSmalltalk80Accessors | t | t _ DateAndTime year: 1 month: 1 day: 2 hour: 2 minute: 3 second: 4 nanoSecond: 5 offset: 6 hours. self assert: (t hours = t hours); assert: (t minutes = t minute); assert: (t seconds = t second). ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:18'! testTimeZoneEquivalence "DateAndTimeTest new testTimeZoneEquivalence" "When the clock on the wall in Detroit says 9:00am, the clock on the wall in London says 2:00pm. The Duration difference between the corresponding DateAndTime values should be zero." " Detroit is 5 hours behind UTC, this offset to UTC is therefore written with a minus sign. This example tests both the correct interpretation of the DateAndTime denotation and correct DateAndTime arithmetics. " | twoPmInLondon nineAmInDetroit durationDifference | twoPmInLondon _ '2004-11-02T14:00:00+00:00' asDateAndTime. nineAmInDetroit _ '2004-11-02T09:00:00-05:00' asDateAndTime. durationDifference _ twoPmInLondon - nineAmInDetroit. self assert: durationDifference asSeconds = 0. self assert: twoPmInLondon = nineAmInDetroit ! ! !DateAndTimeTest methodsFor: 'Tests' stamp: 'BG 11/7/2004 12:17'! testTimeZoneEquivalence2 "DateAndTimeTest new testTimeZoneEquivalence2" "This example demonstates the fact that 2004-05-24T22:40:00 UTC is 2004-05-25T01:40:00 in Moscow (Moscow is 3 hours ahead of UTC) " | thisMoment thisMomentInMoscow | thisMoment := DateAndTime year: 2004 month: 5 day: 24 hour: 22 minute: 40. thisMomentInMoscow := thisMoment utcOffset: 3 hours. self assert: (thisMoment - thisMomentInMoscow) asSeconds = 0. self assert: thisMoment = thisMomentInMoscow ! ! !DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! classToBeTested ^ DateAndTime ! ! !DateAndTimeTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 09:25'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:07'! testAccessing self assert: date day = 153; assert: date julianDayNumber = 2441836; assert: date leap = 0; assert: date monthIndex = 6; assert: date monthName = #June; assert: date weekday = #Saturday; assert: date weekdayIndex = 7; assert: date year = 1973. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:10'! testArithmetic | d | d := date addDays: 32. "4 July 1973" self assert: d year = 1973; assert: d monthIndex = 7; assert: d dayOfMonth = 4. self assert: (d subtractDate: date) = 32; assert: (date subtractDate: d) = -32. self assert: (d subtractDays: 32) = date. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:54'! testComparing | d1 d2 d3 | d1 := self dateClass newDay: 2 month: #June year: 1973. d2 := self dateClass newDay: 97 year: 2003. "7 April 2003" d3 := self dateClass newDay: 250 year: 1865. "7 September 1865" self assert: date = d1; assert: date = date copy; assert: date hash = d1 hash. self assert: date < d2; deny: date < d3. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:15'! testConverting self assert: date asDate = date; assert: '2 June 1973' asDate = date; assert: date asSeconds = 2285280000. date dayMonthYearDo: [ :d :m :y | self assert: d = 2; assert: m = 6; assert: y = 1973 ].! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:47'! testFromDays | epoch d0 d1 d2 | epoch := self dateClass newDay: 1 year: 1901. d0 := self dateClass fromDays: 0. "1 January 1901" self assert: d0 = epoch. d1 := self dateClass fromDays: 26450. "2 June 1973" self assert: d1 = date. d2 := self dateClass fromDays: -100000. "18 March 1627" self assert: d2 julianDayNumber = 2315386. self assert: aDate = (Date fromDays: 37642). self assert: aDate = (Date fromDays: 103*365 + 22 + 25 "leap days") . ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! testFromSeconds | d | d := self dateClass fromSeconds: 2285280000. self assert: d = date. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/7/2004 16:37'! testGeneralInquiries | shuffled indices names now | shuffled := #(#January #February #March #April #May #June #July #August #September #October #November #December) shuffled. indices := shuffled collect: [ :m | self dateClass indexOfMonth: m ]. names := indices collect: [ :i | self dateClass nameOfMonth: i ]. self assert: names = shuffled. shuffled := #(#Monday #Tuesday #Wednesday #Thursday #Friday #Saturday #Sunday) shuffled. indices := shuffled collect: [ :m | self dateClass dayOfWeek: m ]. names := indices collect: [ :i | self dateClass nameOfDay: i ]. self assert: names = shuffled. now := self dateClass dateAndTimeNow. self assert: now size = 2; assert: now first = self dateClass today. self assert: (self dateClass firstWeekdayOfMonth: #June year: 1973) = 6. self assert: (self dateClass leapYear: 1973) = 0; assert: (self dateClass leapYear: 1972) = 1; assert: (self dateClass daysInYear: 1973) = 365; assert: (self dateClass daysInYear: 1972) = 366; assert: (self dateClass daysInMonth: #February forYear: 1973) = 28; assert: (self dateClass daysInMonth: #February forYear: 1972) = 29. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:17'! testInitialization self should: [ self dateClass initialize. true ]. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:18'! testInquiries self assert: date dayOfMonth = 2; assert: date dayOfYear = 153; assert: date daysInMonth = 30; assert: date daysInYear = 365; assert: date daysLeftInYear = (365 - 153); assert: date firstDayOfMonth = 152. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! testNew | epoch | epoch := self dateClass newDay: 1 year: 1901. self assert: (self dateClass new = epoch).! ! !DateTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 16:33'! testPreviousNext | n p pt ps | n := date next. p := date previous. self assert: n year = 1973; assert: n dayOfYear = 154; assert: p year = 1973; assert: p dayOfYear = 152. pt := date previous: #Thursday. "31 May 1973" self assert: pt year = 1973; assert: pt dayOfYear = 151. ps := date previous: #Saturday. " 26 May 1973" self assert: ps year = 1973; assert: ps dayOfYear = (153-7). ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:21'! testPrinting self assert: date mmddyyyy = '6/2/1973'; assert: date yyyymmdd = '1973-06-02'; assert: (date printFormat: #(3 1 2 $!! 2 1 1)) = '1973!!2!!Jun'. ! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:23'! testReadFrom | s1 s2 s3 s4 s5 | s1 := '2 June 1973'. s2 := '2-JUN-73'. s3 := 'June 2, 1973'. s4 := '6/2/73'. s5 := '2JUN73'. self assert: date = (self dateClass readFrom: s1 readStream); assert: date = (self dateClass readFrom: s2 readStream); assert: date = (self dateClass readFrom: s3 readStream); assert: date = (self dateClass readFrom: s4 readStream); assert: date = (self dateClass readFrom: s5 readStream).! ! !DateTest methodsFor: 'Tests' stamp: 'brp 7/27/2003 13:05'! testStoring self assert: date storeString = '''2 June 1973'' asDate'; assert: date = ('2 June 1973' asDate). ! ! !DateTest methodsFor: 'Private' stamp: 'brp 8/24/2003 00:10'! dateClass ^ Date! ! !DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'! classToBeTested ^ self dateClass! ! !DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 14:05'! selectorsToBeIgnored | deprecated private special | deprecated := #( #fromJulianDayNumber: #uniqueDateStringBetween:and: #daylightSavingsInEffectAtStandardHour: #daylightSavingsInEffect #asGregorian #asJulianDayNumber #day:year: #firstDayOfMonthIndex: #mmddyy #absoluteDaysToYear: #yearAndDaysFromDays:into: #week #month ). private := #( #julianDayNumber: ). special := #( #< #= #new #next #previous #printOn: #printOn:format: #storeOn: #fromString: ). ^ super selectorsToBeIgnored, deprecated, private, special! ! !DateTest methodsFor: 'Running' stamp: 'brp 1/21/2004 18:46'! setUp date := self dateClass newDay: 153 year: 1973. "2 June 1973" aDate := Date readFrom: '01-23-2004' readStream. aTime := Time readFrom: '12:34:56 pm' readStream! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAddDays self assert: (aDate addDays: 00) yyyymmdd = '2004-01-23'. self assert: (aDate addDays: 30) yyyymmdd = '2004-02-22'. self assert: (aDate addDays: 60) yyyymmdd = '2004-03-23'. self assert: (aDate addDays: 90) yyyymmdd = '2004-04-22'. self assert: (aDate addDays:120) yyyymmdd = '2004-05-22'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAsDate self assert: (aDate asDate) = aDate ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testAsSeconds self assert: (aDate asSeconds) = 3252268800. self assert: (aDate asSeconds) = ((103*365*24*60*60) + (22+25"leap days"*24*60*60)) . self assert: aDate = (Date fromSeconds: 3252268800).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDateAndTimeNow "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch time errors" self assert: Date dateAndTimeNow first = Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDayMonthYearDo self assert: (aDate dayMonthYearDo: [:day :month :year | day asString , month asString, year asString]) = '2312004' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDaysInMonthForYear self assert: (Date daysInMonth: 'February' forYear: 2008) = 29. self assert: (Date daysInMonth: 'February' forYear: 2000) = 29. self assert: (Date daysInMonth: 'February' forYear: 2100) = 28. self assert: (Date daysInMonth: 'July' forYear: 2100) = 31. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDaysInYear self assert: (Date daysInYear: 2008) = 366. self assert: (Date daysInYear: 2000) = 366. self assert: (Date daysInYear: 2100) = 365 ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testDuration self assert: aDate duration = 24 hours! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testEqual self assert: aDate = (Date readFrom: (ReadStream on: 'January 23, 2004')).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testFirstWeekdayOfMonthYear self assert: (Date firstWeekdayOfMonth: 'January' year: 2004) = 5. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testIndexOfMonth self assert: (Date indexOfMonth: 'January') = 1. self assert: (Date indexOfMonth: 'December') = 12. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testJulianDayNumber self assert: aDate = (Date julianDayNumber: ((4713+2004)*365 +1323) ). ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLeap self assert: aDate leap = 1. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLeapNot self assert: (aDate addDays: 365) leap = 0 ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testLessThan self assert: aDate < (Date readFrom: (ReadStream on: '01-24-2004')).! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testMmddyyyy self assert: aDate mmddyyyy = '1/23/2004'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNameOfMonth self assert: (Date nameOfMonth: 5) = 'May'. self assert: (Date nameOfMonth: 8) = 'August' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNewDayMonthYear self assert: aDate = (Date newDay: 23 month: 1 year: 2004) ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testNewDayYear self assert: aDate = (Date newDay: 23 year: 2004) ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPreviousFriday self assert: (aDate previous: 'Friday') yyyymmdd = '2004-01-16' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPreviousThursday self assert: (aDate previous: 'Thursday') yyyymmdd = '2004-01-22' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintFormat self assert: (aDate printFormat: #(1 2 3 $? 2 2)) = '23?Jan?04'! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintOn | cs rw | cs := ReadStream on: '23 January 2004'. rw := ReadWriteStream on: ''. aDate printOn: rw. self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testPrintOnFormat | cs rw | cs := ReadStream on: '04*Jan*23'. rw := ReadWriteStream on: ''. aDate printOn: rw format: #(3 2 1 $* 2 2). self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testStarting self assert: aDate = (Date starting: (DateAndTime fromString: '2004-01-23T12:12')). ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testStoreOn | cs rw | cs := ReadStream on: '''23 January 2004'' asDate'. rw := ReadWriteStream on: ''. aDate storeOn: rw. self assert: rw contents = cs contents! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testSubtractDate self assert: (aDate subtractDate:(aDate addDays: 30)) = -30. self assert: (aDate subtractDate:(aDate subtractDays: 00)) = 0. self assert: (aDate subtractDate:(aDate subtractDays: 30)) = 30. ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testSubtractDays self assert: (aDate subtractDays: 00) yyyymmdd = '2004-01-23'. self assert: (aDate subtractDays: 30) yyyymmdd = '2003-12-24'. self assert: (aDate subtractDays: 60) yyyymmdd = '2003-11-24' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testTomorrow "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch many errors" self assert: Date tomorrow > Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testWeekday self assert: aDate weekday = 'Friday'. self assert: aDate weekdayIndex = 6. self assert: (Date dayOfWeek: aDate weekday ) =6. self assert: (Date nameOfDay: 6 ) = 'Friday' ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testYesterday "Not a great test: doesnt catch many errors" self assert: Date yesterday < Date today ! ! !DateTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:48'! testYyyymmdd self assert: aDate yyyymmdd = '2004-01-23'! ! !DateTest commentStamp: 'brp 7/26/2003 16:58' prior: 0! This is the unit test for the class Date. ! !Debugger methodsFor: 'initialize' stamp: 'sw 1/16/2002 20:03'! buildMVCNotifierButtonView | aView bHeight priorButton buttonView | aView _ View new model: self. bHeight _ self notifierButtonHeight. aView window: (0@0 extent: 350@bHeight). priorButton _ nil. self preDebugButtonQuads do: [:aSpec | buttonView _ PluggableButtonView on: self getState: nil action: aSpec second. buttonView label: aSpec first; insideColor: (Color perform: aSpec third) muchLighter lighter; borderWidthLeft: 1 right: 1 top: 0 bottom: 0; window: (0@0 extent: 117@bHeight). priorButton ifNil: [aView addSubView: buttonView] ifNotNil: [aView addSubView: buttonView toRightOf: priorButton]. priorButton _ buttonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'hmm 7/30/2001 17:25'! buildMVCOptionalButtonsButtonsView | aView bHeight offset aButtonView wid pairs windowWidth previousView | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 150. aView window: (0@0 extent: windowWidth@bHeight). offset _ 0. pairs _ self optionalButtonPairs. previousView _ nil. pairs do: [:pair | aButtonView _ PluggableButtonView on: self getState: nil action: pair second. pair second = pairs last second ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ windowWidth // (pairs size)]. aButtonView label: pair first asParagraph; insideColor: Color red muchLighter lighter; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. pair second = pairs first second ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'nk 2/12/2003 22:56'! buttonRowForPreDebugWindow: aDebugWindow | aRow aButton quads | aRow _ AlignmentMorph newRow hResizing: #spaceFill. aRow beSticky. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer. quads _ OrderedCollection withAll: self preDebugButtonQuads. (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' } ]. quads do: [:quad | aButton _ SimpleButtonMorph new target: aDebugWindow. aButton color: Color transparent; borderWidth: 1. aButton actionSelector: quad second. aButton label: quad first. aButton submorphs first color: (Color colorFrom: quad third). aButton setBalloonText: quad fourth. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addMorphBack: AlignmentMorph newVariableTransparentSpacer]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'sw 8/21/2002 18:40'! customButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | aRow aButton aLabel | aRow _ AlignmentMorph newRow beSticky. aRow setNameTo: 'customButtonPane'. aRow clipSubmorphs: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self customButtonSpecs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; onColor: Color transparent offColor: Color transparent. (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second) ifTrue: [aButton askBeforeChanging: true]. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]). tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'ab 2/25/2004 18:59'! customButtonSpecs "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." | list | list _ #(('Proceed' proceed 'close the debugger and proceed.') ('Restart' restart 'reset this context to its start.') ('Into' send 'step Into message sends') ('Over' doStep 'step Over message sends') ('Through' stepIntoBlock 'step into a block') ('Full Stack' fullStack 'show full stack') ('Where' where 'select current pc range')). Preferences restartAlsoProceeds ifTrue: [list _ list collect: [:each | each second == #restart ifTrue: [each copy at: 3 put: 'proceed from the beginning of this context.'; yourself] ifFalse: [each]]]. ^ list! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 7/20/2003 23:41'! errorWasInUIProcess: boolean errorWasInUIProcess _ boolean! ! !Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:20'! initialExtent "Make the full debugger longer!!" dependents size < 9 ifTrue: [^ super initialExtent]. "Pre debug window" RealEstateAgent standardWindowExtent y < 400 "a tiny screen" ifTrue: [^ super initialExtent]. ^ 600@700 ! ! !Debugger methodsFor: 'initialize' stamp: 'tk 5/9/2003 11:07'! openFullMorphicLabel: aLabelString "Open a full morphic debugger with the given label" | window aListMorph oldContextStackIndex | oldContextStackIndex _ contextStackIndex. self expandStack. "Sets contextStackIndex to zero." window _ (SystemWindow labelled: aLabelString) model: self. aListMorph _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 corner: 1@0.25). self addLowerPanesTo: window at: (0@0.25 corner: 1@0.8) with: nil. window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0@0.8 corner: 0.2@1). window addMorph: (PluggableTextMorph on: self receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.2@0.8 corner: 0.5@1). window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: self contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0.5@0.8 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0.7@0.8 corner: 1@1). window openInWorld. self toggleContextStackIndex: oldContextStackIndex. ^ window ! ! !Debugger methodsFor: 'initialize' stamp: 'di 10/28/2001 10:59'! openNotifierContents: msgString label: label "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired." "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." | msg topView p | Sensor flushKeyboard. savedCursor _ Sensor currentCursor. Sensor currentCursor: Cursor normal. (label beginsWith: 'Space is low') ifTrue: [msg _ self lowSpaceChoices, (msgString ifNil: [''])] ifFalse: [msg _ msgString]. isolationHead ifNotNil: ["We have already revoked the isolation layer -- now jump to the parent project." msg _ self isolationRecoveryAdvice, msgString. failedProject _ Project current. isolationHead parent enterForEmergencyRecovery]. Smalltalk isMorphic ifTrue: [ self buildMorphicNotifierLabelled: label message: msg. errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: interruptedProcess. ^self ]. Display fullScreen. topView _ self buildMVCNotifierViewLabel: label message: thisContext sender sender shortStack minSize: 350@((14 * 5) + 16 + self optionalButtonHeight). ScheduledControllers activeController ifNil: [p _ Display boundingBox center] ifNotNil: [p _ ScheduledControllers activeController view displayBox center]. topView controller openNoTerminateDisplayAt: (p max: (200@60)). ^ topView! ! !Debugger methodsFor: 'initialize' stamp: 'sw 8/23/2002 00:23'! optionalButtonPairs "Actually, return triples. In mvc (until someone deals with this) only the custom debugger-specific buttons are shown, but in morphic, the standard code-tool buttons are provided in addition to the custom buttons" ^ Smalltalk isMorphic ifFalse: [self customButtonSpecs] ifTrue: [super optionalButtonPairs]! ! !Debugger methodsFor: 'initialize' stamp: 'sw 12/14/2001 01:29'! optionalButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | aRow aButton aLabel | aRow _ AlignmentMorph newRow beSticky. aRow setNameTo: 'buttonPane'. aRow clipSubmorphs: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonPairs do: [:tuple | aButton _ PluggableButtonMorph on: self getState: nil action: tuple second. aButton hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; onColor: Color transparent offColor: Color transparent. (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second) ifTrue: [aButton askBeforeChanging: true]. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: tuple second] ifFalse: [nil]. aButton label: (aLabel ifNil: [tuple first asString]). tuple size > 2 ifTrue: [aButton setBalloonText: tuple third]. Preferences alternativeWindowLook ifTrue:[aButton borderWidth: 2; borderColor: #raised]. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'yo 3/15/2005 13:18'! preDebugButtonQuads ^Preferences eToyFriendly ifTrue: [ { {'Store log' translated. #storeLog. #blue. 'write a log of the encountered problem' translated}. {'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}. {'Debug' translated. #debug. #red. 'bring up a debugger' translated}}] ifFalse: [ { {'Proceed' translated. #proceed. #blue. 'continue execution' translated}. {'Abandon' translated. #abandon. #black. 'abandon this execution by closing this window' translated}. {'Debug' translated. #debug. #red. 'bring up a debugger' translated}}] ! ! !Debugger methodsFor: 'initialize' stamp: 'yo 7/2/2004 17:42'! preDebugNotifierContentsFrom: messageString ^ Preferences eToyFriendly ifFalse: [messageString] ifTrue: ['An error has occurred; you should probably just hit ''abandon''. Sorry!!' translated] ! ! !Debugger methodsFor: 'initialize' stamp: 'ajh 3/5/2004 21:31'! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. interruptedProcess terminate. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'accessing' stamp: 'nk 7/10/2004 14:17'! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | selector classOfMethod category h ctxt newMethod | contextStackIndex = 0 ifTrue: [^ false]. self selectedContext isExecutingBlock ifTrue: [h := self selectedContext finalBlockHome. h ifNil: [self inform: 'Method not found for block, can''t edit'. ^ false]. (self confirm: 'I will have to revert to the method from which this block originated. Is that OK?') ifTrue: [self resetContext: h] ifFalse: [^ false]]. classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass parserClass new parseSelector: aText. selector == self selectedMessageName ifFalse: [self inform: 'can''t change selector'. ^ false]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^ false]. "compile cancelled" contents := aText. newMethod := classOfMethod compiledMethodAt: selector. newMethod isQuick ifTrue: [ self down. self selectedContext jump: (self selectedContext previousPc - self selectedContext pc) ]. ctxt := interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifFalse: [ self inform: 'Method saved, but current context unchanged because of unwind error. Click OK to see error'. ] ifTrue: [ newMethod isQuick ifFalse: [ interruptedProcess restartTopWith: newMethod; stepToSendOrReturn ]. contextVariablesInspector object: nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ctxt methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting] ifFalse: [ctxt methodNode]. sourceMap := theMethodNode sourceMap. tempNames := theMethodNode tempNames. ]. self resetContext: ctxt. Smalltalk isMorphic ifTrue: [ World addAlarm: #changed: withArguments: #(contentsSelection) for: self at: (Time millisecondClockValue + 200) ]. ^ true ! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString ^labelString! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString: aString labelString _ aString. self changed: #relabel! ! !Debugger methodsFor: 'notifier menu' stamp: 'jcg 3/7/2003 01:47'! debug "Open a full DebuggerView." | topView | topView _ self topView. topView model: nil. "so close won't release me." Smalltalk isMorphic ifTrue: [self breakDependents. topView delete. ^ self openFullMorphicLabel: topView label]. topView controller controlTerminate. topView deEmphasize; erase. "a few hacks to get the scroll selection artifacts out when we got here by clicking in the list" topView subViewWantingControl ifNotNil: [ topView subViewWantingControl controller controlTerminate ]. topView controller status: #closed. self openFullNoSuspendLabel: topView label. topView controller closeAndUnscheduleNoErase. Processor terminateActive. ! ! !Debugger methodsFor: 'notifier menu' stamp: 'mir 3/5/2004 19:26'! storeLog | logFileName | logFileName := Preferences debugLogTimestamp ifTrue: ['SqueakDebug-' , Time totalSeconds printString , '.log'] ifFalse: ['SqueakDebug.log']. Smalltalk logError: labelString printString inContext: contextStackTop to: logFileName ! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/25/2001 00:14'! fullyExpandStack "Expand the stack to include all of it, rather than the first four or five contexts." self okToChange ifFalse: [^ self]. self newStack: contextStackTop contextStack. self changed: #contextStackList! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'nk 2/20/2004 15:55'! selectedMessage "Answer the source code of the currently selected context." contents := theMethodNode sourceText. ^ contents := contents asText makeSelectorBold! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'ajh 9/7/2002 21:15'! selectedMessageName "Answer the message selector of the currently selected context." ^self selectedContext methodSelector! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 3/4/2004 20:39'! askForCategoryIn: aClass default: aString | categories index category | categories := OrderedCollection with: 'new ...'. categories addAll: (aClass allMethodCategoriesIntegratedThrough: Object). index := PopUpMenu withCaption: 'Please provide a good category for the new method!!' translated chooseFrom: categories. index = 0 ifTrue: [^ aString]. category := index = 1 ifTrue: [FillInTheBlank request: 'Enter category name:'] ifFalse: [categories at: index]. ^ category isEmpty ifTrue: [^ aString] ifFalse: [category]! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 9/14/2001 00:26'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. VersionsBrowser browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass theNonMetaClass meta: class isMeta category: self selectedMessageCategoryName selector: selector! ! !Debugger methodsFor: 'context stack menu' stamp: 'hg 10/2/2001 20:22'! buildMorphicNotifierLabelled: label message: messageString | notifyPane window contentTop extentToUse | self expandStack. window _ (PreDebugWindow labelled: label) model: self. contentTop _ 0.2. extentToUse _ 450 @ 156. "nice and wide to show plenty of the error msg" window addMorph: (self buttonRowForPreDebugWindow: window) frame: (0@0 corner: 1 @ contentTop). Preferences eToyFriendly | messageString notNil ifFalse: [notifyPane _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #debugAt: menu: nil keystroke: nil] ifTrue: [notifyPane _ PluggableTextMorph on: self text: nil accept: nil readSelection: nil menu: #debugProceedMenu:. notifyPane editString: (self preDebugNotifierContentsFrom: messageString); askBeforeDiscardingEdits: false]. window addMorph: notifyPane frame: (0@contentTop corner: 1@1). "window deleteCloseBox. chickened out by commenting the above line out, sw 8/14/2000 12:54" window setBalloonTextForCloseBox. ^ window openInWorldExtent: extentToUse! ! !Debugger methodsFor: 'context stack menu' stamp: 'kfr 9/24/2004 21:42'! contextStackMenu: aMenu shifted: shifted "Set up the menu appropriately for the context-stack-list, either shifted or unshifted as per the parameter provided" ^ shifted ifFalse: [self selectedContext selector = #doesNotUnderstand: ifTrue: [aMenu add: 'implement in...' subMenu: (self populateImplementInMenu: (Smalltalk isMorphic ifTrue: [MenuMorph new defaultTarget: self] ifFalse: [CustomMenu new])) target: nil selector: nil argumentList: #(nil)]. aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) step through (T) send (e) where (w) peel to first like this return entered value toggle break on entry senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out mail out bug report more...' lines: #(8 9 13 15 18 21) selections: #(fullStack restart proceed doStep stepIntoBlock send where peelToFirst returnValue toggleBreakOnEntry browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage mailOutBugReport shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert & remove from changes more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 7/6/2003 21:06'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self checkContextSelection. currentContext _ self selectedContext. newContext _ interruptedProcess completeStep: currentContext. newContext == currentContext ifTrue: [ newContext _ interruptedProcess stepToSendOrReturn]. self contextStackIndex > 1 ifTrue: [self resetContext: newContext] ifFalse: [newContext == currentContext ifTrue: [self changed: #contentsSelection. self updateInspectors] ifFalse: [self resetContext: newContext]]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'nk 7/10/2004 14:11'! implement: aMessage inClass: aClass | category | category := self askForCategoryIn: aClass default: 'as yet unclassified'. aClass compile: aMessage createStubMethod classified: category. self setContentsToForceRefetch. self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). self resetContext: self selectedContext. self debug. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'dvf 5/11/2002 00:51'! mailOutBugReport "Compose a useful bug report showing the state of the process as well as vital image statistics as suggested by Chris Norton - 'Squeak could pre-fill the bug form with lots of vital, but oft-repeated, information like what is the image version, last update number, VM version, platform, available RAM, author...' and address it to the list with the appropriate subject prefix." | messageStrm | MailSender default ifNil: [^self]. Cursor write showWhile: ["Prepare the message" messageStrm _ WriteStream on: (String new: 1500). messageStrm nextPutAll: 'From: '; nextPutAll: MailSender userName; cr; nextPutAll: 'To: squeak-dev@lists.squeakfoundation.org'; cr; nextPutAll: 'Subject: '; nextPutAll: '[BUG]'; nextPutAll: self interruptedContext printString; cr;cr; nextPutAll: 'here insert explanation of what you were doing, suspect changes you''ve made and so forth.';cr;cr. self interruptedContext errorReportOn: messageStrm. MailSender sendMessage: (MailMessage from: messageStrm contents)]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 3/16/2001 17:20'! messageListMenu: aMenu shifted: shifted "The context-stack menu takes the place of the message-list menu in the debugger, so pass it on" ^ self contextStackMenu: aMenu shifted: shifted! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:10'! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second ctxt | contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. ctxt _ interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifTrue: [self resetContext: second] ifFalse: [self resetContext: ctxt]. "unwind error" ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ads 2/20/2003 08:46'! populateImplementInMenu: aMenu | msg | msg _ self selectedContext at: 1. self selectedContext receiver class withAllSuperclasses do: [:each | aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)]. ^ aMenu ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'! proceed: aTopView "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed." self okToChange ifFalse: [^ self]. self checkContextSelection. self resumeProcess: aTopView! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 3/4/2004 23:14'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a preference #restartAlsoProceeds - hmm 9/7/2001 16:46" | ctxt noUnwindError | self okToChange ifFalse: [^ self]. self checkContextSelection. ctxt _ interruptedProcess popTo: self selectedContext. noUnwindError _ false. ctxt == self selectedContext ifTrue: [ noUnwindError _ true. interruptedProcess restartTop; stepToSendOrReturn]. self resetContext: ctxt. (Preferences restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'nk 2/22/2005 15:29'! returnValue "Force a return of a given value to the previous context!!" | previous selectedContext expression value | contextStackIndex = 0 ifTrue: [^Beeper beep]. selectedContext := self selectedContext. expression := FillInTheBlank request: 'Enter expression for return value:'. value := Compiler new evaluate: expression in: selectedContext to: selectedContext receiver. previous := selectedContext sender. self resetContext: previous. interruptedProcess popTo: previous value: value! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:29'! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." self okToChange ifFalse: [^ self]. self checkContextSelection. interruptedProcess step: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'ajh 1/24/2003 12:46'! stepIntoBlock "Send messages until you return to the present method context. Used to step into a block in the method." interruptedProcess stepToHome: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn.! ! !Debugger methodsFor: 'context stack menu' stamp: 'nk 2/6/2001 19:34'! where "Select the expression whose evaluation was interrupted." selectingPC _ true. self contextStackIndex: contextStackIndex oldContextWas: self selectedContext ! ! !Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'! contentsSelection ^ self pcRange! ! !Debugger methodsFor: 'code pane' stamp: 'nk 2/20/2004 15:35'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i pc end | (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. sourceMap ifNil: [sourceMap _ theMethodNode sourceMap. tempNames _ theMethodNode tempNames. self selectedContext method cacheTempNames: tempNames]. (sourceMap size = 0 or: [ self selectedContext isDead ]) ifTrue: [^1 to: 0]. Smalltalk at: #RBProgramNode ifPresent:[:nodeClass| (theMethodNode isKindOf: nodeClass) ifTrue: [ pc _ contextStackIndex = 1 ifTrue: [self selectedContext pc] ifFalse: [self selectedContext previousPc]. i _ sourceMap findLast:[:pcRange | pcRange key <= pc]. i = 0 ifTrue:[^ 1 to: 0]. ^ (sourceMap at: i) value ]. ]. pc_ self selectedContext pc - (("externalInterrupt" true and: [contextStackIndex=1]) ifTrue: [1] ifFalse: [2]). i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end+1 to: end]. ^(sourceMap at: i) value! ! !Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'! updateInspectors "Update the inspectors on the receiver's variables." receiverInspector == nil ifFalse: [receiverInspector update]. contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! ! !Debugger methodsFor: 'private' stamp: 'ads 2/15/2003 13:34'! askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock | classes chosenClassIndex | classes _ aClass withAllSuperclasses. chosenClassIndex _ PopUpMenu withCaption: 'Define #', aSelector, ' in which class?' chooseFrom: (classes collect: [:c | c name]). chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. ^ classes at: chosenClassIndex! ! !Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34'! checkContextSelection contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil]. ! ! !Debugger methodsFor: 'private' stamp: 'nk 2/20/2004 16:51'! contextStackIndex: anInteger oldContextWas: oldContext "Change the context stack index to anInteger, perhaps in response to user selection." | newMethod | contextStackIndex := anInteger. anInteger = 0 ifTrue: [currentCompiledMethod := theMethodNode := tempNames := sourceMap := contents := nil. self changed: #contextStackIndex. self decorateButtons. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^ self]. (newMethod := oldContext == nil or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)]) ifTrue: [tempNames := sourceMap := nil. theMethodNode := Preferences browseWithPrettyPrint ifTrue: [ self selectedContext methodNodeFormattedAndDecorated: Preferences colorWhenPrettyPrinting ] ifFalse: [ self selectedContext methodNode ]. contents := self selectedMessage. self contentsChanged. self pcRange "will compute tempNamesunless noFrills"]. self changed: #contextStackIndex. self decorateButtons. tempNames == nil ifTrue: [tempNames := self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil]. contextVariablesInspector object: self selectedContext. receiverInspector object: self receiver. newMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private' stamp: 'nk 7/10/2004 12:31'! createMethod "Should only be called when this Debugger was created in response to a MessageNotUnderstood exception. Create a stub for the method that was missing and proceed into it." | msg chosenClass | msg _ contextStackTop tempAt: 1. chosenClass _ self askForSuperclassOf: contextStackTop receiver class toImplement: msg selector ifCancel: [^self]. self implement: msg inClass: chosenClass. ! ! !Debugger methodsFor: 'private' stamp: 'yo 12/3/2004 17:14'! lowSpaceChoices "Return a notifier message string to be presented when space is running low." ^ 'Warning!! Squeak is almost out of memory!! Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. Here are some suggestions: If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... > Close any windows that are not needed. > Get rid of some large objects (e.g., images). > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). ' ! ! !Debugger methodsFor: 'private' stamp: 'sw 7/29/2002 23:27'! process: aProcess controller: aController context: aContext isolationHead: projectOrNil super initialize. Smalltalk at: #MessageTally ifPresentAndInMemory: [:c | c new close]. contents _ nil. interruptedProcess _ aProcess. interruptedController _ aController. contextStackTop _ aContext. self newStack: (contextStackTop stackOfSize: 1). contextStackIndex _ 1. externalInterrupt _ false. selectingPC _ true. isolationHead _ projectOrNil. Smalltalk isMorphic ifTrue: [errorWasInUIProcess _ false]! ! !Debugger methodsFor: 'private' stamp: 'nk 7/10/2004 12:51'! resetContext: aContext "Used when a new context becomes top-of-stack, for instance when the method of the selected context is re-compiled, or the simulator steps or returns to a new method. There is room for much optimization here, first to save recomputing the whole stack list (and text), and secondly to avoid recomposing all that text (by editing the paragraph instead of recreating it)." | oldContext | oldContext _ self selectedContext. contextStackTop _ aContext. self newStack: contextStackTop contextStack. self changed: #contextStackList. self contextStackIndex: 1 oldContextWas: oldContext. self contentsChanged. ! ! !Debugger methodsFor: 'private' stamp: 'ajh 7/21/2003 10:08'! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. isolationHead ifNotNil: [failedProject enterForEmergencyRecovery. isolationHead invoke. isolationHead _ nil]. interruptedProcess isTerminated ifFalse: [ Smalltalk isMorphic ifTrue: [errorWasInUIProcess ifTrue: [Project resumeProcess: interruptedProcess] ifFalse: [interruptedProcess resume]] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger methodsFor: 'controls' stamp: 'sw 9/3/2002 10:24'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "Add button panes to the window. A row of custom debugger-specific buttons (Proceed, Restart, etc.) is always added, and if optionalButtons is in force, then the standard code-tool buttons are also added. Answer the verticalOffset plus the height added." | delta buttons divider anOffset | anOffset _ (Preferences optionalButtons and: [Preferences extraDebuggerButtons]) ifTrue: [super addOptionalButtonsTo: window at: fractions plus: verticalOffset] ifFalse: [verticalOffset]. delta _ self defaultButtonPaneHeight. buttons _ self customButtonRow. buttons color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); borderWidth: 0. Preferences alternativeWindowLook ifTrue: [buttons color: Color transparent. buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised]]. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue: [divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2]. window addMorph: buttons fullFrame: (LayoutFrame fractions: fractions offsets: (0@anOffset corner: 0@(anOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(anOffset + delta - 1) corner: 0@(anOffset + delta))). ^ anOffset + delta! ! !Debugger methodsFor: 'as yet unclassified' stamp: 'nk 8/6/2003 13:52'! codePaneMenu: aMenu shifted: shifted aMenu add: 'run to here' target: self selector: #runToSelection: argument: thisContext sender receiver selectionInterval. aMenu addLine. super codePaneMenu: aMenu shifted: shifted. ^aMenu.! ! !Debugger methodsFor: 'as yet unclassified' stamp: 'nk 5/31/2003 07:38'! runToSelection: selectionInterval | currentContext | self pc first >= selectionInterval first ifTrue: [ ^self ]. currentContext _ self selectedContext. [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! ! !Debugger methodsFor: 'breakpoints' stamp: 'emm 5/30/2002 10:08'! toggleBreakOnEntry "Install or uninstall a halt-on-entry breakpoint" | selectedMethod | self selectedClassOrMetaClass isNil ifTrue:[^self]. selectedMethod := self selectedClassOrMetaClass >> self selectedMessageName. selectedMethod hasBreakpoint ifTrue: [BreakpointManager unInstall: selectedMethod] ifFalse: [BreakpointManager installInClass: self selectedClassOrMetaClass selector: self selectedMessageName].! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 9/29/2001 20:24'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #doStep; at: $T put: #stepIntoBlock; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !Debugger class methodsFor: 'class initialization' stamp: 'hg 10/2/2001 20:44'! openContext: aContext label: aString contents: contentsStringOrNil | isolationHead | "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." "Simulation guard" ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log']. ErrorRecursion ifTrue: [ErrorRecursion _ false. (isolationHead _ CurrentProjectRefactoring currentIsolationHead) ifNil: [self primitiveError: aString] ifNotNil: [isolationHead revoke]]. ErrorRecursion _ true. self informExistingDebugger: aContext label: aString. (Debugger context: aContext isolationHead: isolationHead) openNotifierContents: contentsStringOrNil label: aString. ErrorRecursion _ false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'instance creation' stamp: 'di 4/14/2000 16:29'! context: aContext isolationHead: isolationHead "Answer an instance of me for debugging the active process starting with the given context." ^ self new process: Processor activeProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: aContext isolationHead: isolationHead ! ! !Debugger class methodsFor: 'instance creation' stamp: 'hmm 8/3/2001 13:05'! informExistingDebugger: aContext label: aString "Walking the context chain, we try to find out if we're in a debugger stepping situation. If we find the relevant contexts, we must rearrange them so they look just like they would if the methods were excuted outside of the debugger." | ctx quickStepMethod oldSender baseContext | ctx _ thisContext. quickStepMethod _ ContextPart compiledMethodAt: #quickSend:to:with:super:. [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx _ ctx sender]. ctx sender == nil ifTrue: [^self]. baseContext _ ctx. "baseContext is now the context created by the #quickSend... method." oldSender _ ctx _ ctx sender home sender. "oldSender is the context which originally sent the #quickSend... method" [ctx == nil or: [ctx receiver isKindOf: self]] whileFalse: [ctx _ ctx sender]. ctx == nil ifTrue: [^self]. "ctx is the context of the Debugger method #doStep" ctx receiver labelString: aString. ctx receiver externalInterrupt: false; proceedValue: aContext receiver. baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" thisContext swapSender: oldSender. "make myself return to debugger" ErrorRecursion _ false. ^aContext! ! !Debugger class methodsFor: 'opening' stamp: 'yo 3/15/2005 14:48'! openInterrupt: aString onProcess: interruptedProcess "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger | "Simulation guard" debugger _ self new. debugger process: interruptedProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == interruptedProcess]) ifTrue: [ScheduledControllers activeController]) context: interruptedProcess suspendedContext. debugger externalInterrupt: true. Preferences logDebuggerStackToFile ifTrue: [(aString includesSubString: 'Space') & (aString includesSubString: 'low') ifTrue: [ Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']]. Preferences eToyFriendly ifTrue: [World stopRunningAll]. ^ debugger openNotifierContents: nil label: aString ! ! !Debugger class methodsFor: 'opening' stamp: 'ajh 8/6/2003 11:40'! openOn: process context: context label: title contents: contentsStringOrNil fullView: bool "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger." | controller errorWasInUIProcess | Smalltalk isMorphic ifTrue: [errorWasInUIProcess _ CurrentProjectRefactoring newProcessIfUI: process] ifFalse: [controller _ ScheduledControllers activeControllerProcess == process ifTrue: [ScheduledControllers activeController]]. [ [ | debugger | debugger _ self new process: process controller: controller context: context. bool ifTrue: [debugger openFullNoSuspendLabel: title] ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title]. debugger errorWasInUIProcess: errorWasInUIProcess. Preferences logDebuggerStackToFile ifTrue: [ Smalltalk logError: title inContext: context to: 'SqueakDebug.log']. Smalltalk isMorphic ifFalse: [ScheduledControllers searchForActiveController "needed since openNoTerminate (see debugger #open...) does not set up activeControllerProcess if activeProcess (this fork) is not the current activeControllerProcess (see #scheduled:from:)"]. ] on: Error do: [:ex | self primitiveError: 'Orginal error: ', title asString, '. Debugger error: ', ([ex description] on: Error do: ['a ', ex class printString]), ':' ] ] fork. process suspend. ! ! !Debugger class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:10'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Debugger' brightColor: #lightRed pastelColor: #veryPaleRed helpMessage: 'The system debugger.'! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:38'! testUnwindBlock "test if unwind blocks work properly" | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. "deadlock on the semaphore" process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "terminate process" process terminate. self assert: sema isSignaled. ! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:41'! testUnwindDebugger "test if unwind blocks work properly when a debugger is closed" | sema process debugger top | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "everything set up here - open a debug notifier" debugger := Debugger openInterrupt: 'test' onProcess: process. "get into the debugger" debugger debug. top := debugger topView. "set top context" debugger toggleContextStackIndex: 1. "close debugger" top delete. "and see if unwind protection worked" self assert: sema isSignaled.! ! !DebuggerUnwindBug methodsFor: 'as yet unclassified' stamp: 'ar 3/7/2003 01:40'! testUnwindDebuggerWithStep "test if unwind blocks work properly when a debugger is closed" | sema process debugger top | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [sema critical:[sema wait]] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "everything set up here - open a debug notifier" debugger := Debugger openInterrupt: 'test' onProcess: process. "get into the debugger" debugger debug. top := debugger topView. "set top context" debugger toggleContextStackIndex: 1. "do single step" debugger doStep. "close debugger" top delete. "and see if unwind protection worked" self assert: sema isSignaled.! ! !Decompiler methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 01:14'! initSymbols: aClass | nTemps namedTemps | constructor method: method class: aClass literals: method literals. constTable _ constructor codeConstants. instVars _ Array new: aClass instSize. nTemps _ method numTemps. namedTemps _ tempVars ifNil: [method tempNames]. tempVars _ (1 to: nTemps) collect: [:i | i <= namedTemps size ifTrue: [constructor codeTemp: i - 1 named: (namedTemps at: i)] ifFalse: [constructor codeTemp: i - 1]]! ! !Decompiler methodsFor: 'control' stamp: 'ls 1/28/2004 13:29'! statementsForCaseTo: end "Decompile the method from pc up to end and return an array of expressions. If at run time this block will leave a value on the stack, set hasValue to true. If the block ends with a jump or return, set exit to the destination of the jump, or the end of the method; otherwise, set exit = end. Leave pc = end. Note that stack initially contains a CaseFlag which will be removed by a subsequent Pop instruction, so adjust the StackPos accordingly." | blockPos stackPos | blockPos _ statements size. stackPos _ stack size - 1. "Adjust for CaseFlag" [pc < end] whileTrue: [lastPc _ pc. limit _ end. "for performs" self interpretNextInstructionFor: self]. "If there is an additional item on the stack, it will be the value of this block." (hasValue _ stack size > stackPos) ifTrue: [stack last == CaseFlag ifFalse: [ statements addLast: stack removeLast] ]. lastJumpPc = lastPc ifFalse: [exit _ pc]. caseExits add: exit. ^self popTo: blockPos! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'ls 1/28/2004 13:27'! case: dist "statements = keyStmts CascadeFlag keyValueBlock ... keyStmts" | nextCase thenJump stmtStream elements b node cases otherBlock myExits | nextCase _ pc + dist. "Now add CascadeFlag & keyValueBlock to statements" statements addLast: stack removeLast. stack addLast: CaseFlag. "set for next pop" statements addLast: (self blockForCaseTo: nextCase). stack last == CaseFlag ifTrue: "Last case" ["ensure jump is within block (in case thenExpr returns wierdly I guess)" stack removeLast. "get rid of CaseFlag" stmtStream _ ReadStream on: (self popTo: stack removeLast). elements _ OrderedCollection new. b _ OrderedCollection new. [stmtStream atEnd] whileFalse: [(node _ stmtStream next) == CascadeFlag ifTrue: [elements addLast: (constructor codeMessage: (constructor codeBlock: b returns: false) selector: (constructor codeSelector: #-> code: #macro) arguments: (Array with: stmtStream next)). b _ OrderedCollection new] ifFalse: [b addLast: node]]. b size > 0 ifTrue: [self error: 'Bad cases']. cases _ constructor codeBrace: elements. "try find the end of the case" myExits := caseExits removeLast: elements size. myExits := myExits reject: [ :e | e isNil or: [ e < 0 or: [ e > method size ] ] ]. myExits isEmpty ifTrue: [ thenJump := nextCase ] ifFalse: [ thenJump := myExits min ]. otherBlock _ self blockTo: thenJump. stack addLast: (constructor codeMessage: stack removeLast selector: (constructor codeSelector: #caseOf:otherwise: code: #macro) arguments: (Array with: cases with: otherBlock)). myExits isEmpty ifTrue:[ "all branches returned; pop off the statement" statements addLast: stack removeLast. ] ].! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'nk 2/20/2004 11:56'! pushReceiverVariable: offset | var | (var _ instVars at: offset + 1 ifAbsent: []) == nil ifTrue: ["Not set up yet" var _ constructor codeInst: offset. instVars size < (offset + 1) ifTrue: [ instVars _ (Array new: offset + 1) replaceFrom: 1 to: instVars size with: instVars; yourself ]. instVars at: offset + 1 put: var]. stack addLast: var! ! !Decompiler methodsFor: 'public access' stamp: 'ls 1/28/2004 13:10'! decompileBlock: aBlock "Original version timestamp: sn 1/26/98 18:27 (Don't know who's sn?) " "Decompile aBlock, returning the result as a BlockNode. Show temp names from source if available." "Decompiler new decompileBlock: [3 + 4]" | startpc end homeClass blockNode tempNames home source | (home _ aBlock home) ifNil: [^ nil]. method _ home method. (homeClass _ home who first) == #unknown ifTrue: [^ nil]. constructor _ DecompilerConstructor new. method fileIndex ~~ 0 ifTrue: ["got any source code?" source _ [method getSourceFromFile] on: Error do: [:ex | ^ nil]. tempNames _ ([homeClass compilerClass new parse: source in: homeClass notifying: nil] on: (Smalltalk classNamed: 'SyntaxErrorNotification') do: [:ex | ^ nil]) tempNames. self withTempNames: tempNames]. self initSymbols: homeClass. startpc _ aBlock startpc. end _ (method at: startpc - 2) \\ 16 - 4 * 256 + (method at: startpc - 1) + startpc - 1. stack _ OrderedCollection new: method frameSize. caseExits _ OrderedCollection new. statements _ OrderedCollection new: 20. super method: method pc: startpc - 5. blockNode _ self blockTo: end. stack isEmpty ifFalse: [self error: 'stack not empty']. ^ blockNode statements first! ! !Decompiler methodsFor: 'private' stamp: 'ls 1/28/2004 13:11'! decompile: aSelector in: aClass method: aMethod using: aConstructor | block | constructor _ aConstructor. method _ aMethod. self initSymbols: aClass. "create symbol tables" method isQuick ifTrue: [block _ self quickMethod] ifFalse: [stack _ OrderedCollection new: method frameSize. caseExits _ OrderedCollection new. statements _ OrderedCollection new: 20. super method: method pc: method initialPC. block _ self blockTo: method endPC + 1. stack isEmpty ifFalse: [self error: 'stack not empty']]. ^constructor codeMethod: aSelector block: block tempVars: tempVars primitive: method primitive class: aClass! ! !Decompiler methodsFor: 'private' stamp: 'laza 3/29/2004 07:57'! interpretNextInstructionFor: client | code varNames | "Change false here will trace all state in Transcript." true ifTrue: [^ super interpretNextInstructionFor: client]. varNames _ Decompiler allInstVarNames. code _ (self method at: pc) radix: 16. Transcript cr; cr; print: pc; space; nextPutAll: '<' , code, '>'. 8 to: varNames size do: [:i | i <= 10 ifTrue: [Transcript cr] ifFalse: [Transcript space; space]. Transcript nextPutAll: (varNames at: i); nextPutAll: ': '; print: (self instVarAt: i)]. Transcript endEntry. ^ super interpretNextInstructionFor: client! ! !Decompiler commentStamp: 'ls 1/28/2004 13:31' prior: 0! I decompile a method in three phases: Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms) Parser: prefix symbolic codes -> node tree (same as the compiler) Printer: node tree -> text (done by the nodes) instance vars: constructor method instVars tempVars constTable stack statements lastPc exit caseExits - stack of exit addresses that have been seen in the branches of caseOf:'s lastJumpPc lastReturnPc limit hasValue blockStackBase! !Decompiler class methodsFor: 'testing' stamp: 'ls 1/29/2004 23:54'! recompileAllTest "[Decompiler recompileAllTest]" "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" | decompiled ast compiled | SystemNavigation default allBehaviorsDo: [ :behavior | Utilities informUser: (behavior printString) during: [ behavior selectors do: [ :sel | decompiled := Decompiler new decompile: sel in: behavior. ast := Compiler new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. compiled := ast generate: (behavior compiledMethodAt: sel) trailer. behavior addSelector: sel withMethod: compiled. ] ] ]! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'nk 2/20/2004 11:51'! codeInst: index ^VariableNode new name: (instVars at: index + 1 ifAbsent: ['unknown', index asString]) index: index type: LdInstType! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'ajh 11/15/2003 01:20'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node methodTemps | node _ self codeSelector: selector code: nil. tempVars _ vars. methodTemps _ tempVars select: [:t | t scope >= 0]. ^MethodNode new selector: node arguments: (methodTemps copyFrom: 1 to: nArgs) precedence: selector precedence temporaries: (methodTemps copyFrom: nArgs + 1 to: methodTemps size) block: block encoder: (Encoder new initScopeAndLiteralTables temps: tempVars literals: literalValues class: class) primitive: primitive! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:30'! blockingClasses ^ #(CompiledMethod)! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/26/2004 13:25'! decompilerDiscrepancies "classnames, method selector, isMeta" ^ #(#(#AIFFFileReader #readExtendedFloat false) #(#AbstractFont #emphasisStringFor: false) #(#AbstractString #asSmalltalkComment false) #(#AbstractString #compressWithTable: false) #(#AbstractString #howManyMatch: false) #(#Archive #addTree:removingFirstCharacters: false) #(#ArchiveViewer #createButtonBar false) #(#ArchiveViewer #extractAllPossibleInDirectory: false) #(#BMPReadWriter #nextPutImage: false) #(#Bitmap #readCompressedFrom: false) #(#BitmapStreamTests #testOtherClasses false) #(#BlobMorph #mergeSelfWithBlob:atPoint: false) #(#BookMorph #fromRemoteStream: false) #(#BookMorph #saveIndexOfOnly: false) #(#Browser #categorizeAllUncategorizedMethods false) #(#Browser #highlightMessageList:with: false) #(#Categorizer #elementCategoryDict false) #(#ChangeList #selectConflicts: false) #(#ChangeSet #containsMethodAtPosition: false) #(#ChangeSorter #removeContainedInClassCategories false) #(#CodeHolder #getSelectorAndSendQuery:to:with: false) #(#Color #initializeGrayToIndexMap false) #(#ColorForm #maskingMap false) #(#CompiledMethodInspector #fieldList false) #(#ComplexBorder #drawLineFrom:to:on: false) #(#DateAndTime #ticks:offset: false) #(#Dictionary #scanFor: false) #(#DockingBarMorph #example3 false) #(#Envelope #storeOn: false) #(#FFT #transformDataFrom:startingAt: false) #(#FMSound #mixSampleCount:into:startingAt:leftVol:rightVol: false) #(#FTPClient #getDataInto: false) #(#FWT #samples: false) #(#FWT #setAlpha:beta: false) #(#FileList #selectEncoding false) #(#FileList2 #endingSpecs false) #(#FilePackage #conflictsWithUpdatedMethods false) #(#FishEyeMorph #calculateTransform false) #(#FlapsTest #testRegisteredFlapsQuads false) #(#Float #absByteEncode:base: false) #(#Float #absPrintExactlyOn:base: false) #(#Float #absPrintOn:base: false) #(#Float #initialize false) #(#Form #dotOfSize: false) #(#Form #readNativeResourceFrom: false) #(#GIFReadWriter #exampleAnim false) #(#GZipReadStream #on:from:to: false) #(#GraphMorph #drawDataOn: false) #(#HttpUrl #checkAuthorization:retry: false) #(#ImageSegment #verify:matches:knowing: false) #(#Imports #importImageDirectory: false) #(#Integer #digitDiv:neg: false) #(#Integer #take: false) #(#Interval #valuesInclude: false) #(#JPEGHuffmanTable #makeDerivedTables false) #(#JPEGReadWriter #decodeBlockInto:component:dcTable:acTable: false) #(#KeyedIdentitySet #scanFor: false) #(#KeyedSet #scanFor: false) #(#LiteralDictionary #scanFor: false) #(#LoopedSampledSound #mixSampleCount:into:startingAt:leftVol:rightVol: false) #(#MIDIInputParser #processByte: false) #(#MIDIScore #insertEvents:at: false) #(#MPEGMoviePlayerMorph #guessVolumeSlider false) #(#MailMessage #bodyTextFormatted false) #(#MenuIcons #createIconMethodsFromDirectory: false) #(#MenuIcons #decorateMenu: false) #(#MenuMorph #addTitle:icon:updatingSelector:updateTarget: false) #(#MethodDictionary #scanFor: false) #(#MethodFinder #load: false) #(#Morph #addNestedYellowButtonItemsTo:event: false) #(#Morph #addToggleItemsToHaloMenu: false) #(#Morph #duplicateMorphCollection: false) #(#Morph #layoutMenuPropertyString:from: false) #(#Morph #printConstructorOn:indent:nodeDict: false) #(#Morph #privateAddAllMorphs:atIndex: false) #(#Morph #specialNameInModel false) #(#MultiByteBinaryOrTextStream #next: false) #(#MultiByteFileStream #next: false) #(#MultiString #indexOfAscii:inMultiString:startingAt: false) #(#MultiString #findMultiSubstring:in:startingAt:matchTable: false) #(#MultiString #multiStringCompare:with:collated: false) #(#MulticolumnLazyListMorph #setColumnWidthsFor: false) #(#NaturalLanguageTranslator #loadAvailableExternalLocales false) #(#NewParagraph #OLDcomposeLinesFrom:to:delta:into:priorLines:atY: false) #(#NewParagraph #selectionRectsFrom:to: false) #(#Object #copyFrom: false) #(#Object #storeOn: false) #(#ObjectExplorer #step false) #(#ObjectOut #xxxFixup false) #(#OldSocket #getResponseNoLF false) #(#OrderedCollection #copyReplaceFrom:to:with: false) #(#PNGReadWriter #copyPixelsGray: false) #(#PNGReadWriter #copyPixelsGrayAlpha: false) #(#PNMReadWriter #nextPutBW:reverse: false) #(#PNMReadWriter #nextPutRGB: false) #(#PNMReadWriter #readBWreverse: false) #(#PNMReadWriter #readPlainRGB false) #(#PRServerDirectory #getPostArgsFromThingsToSearchFor: false) #(#PRServerDirectory #putSmalltalkInfoInto: false) #(#PackageInfo #foreignClasses false) #(#ParagraphEditor #cursorEnd: false) #(#ParagraphEditor #explainDelimitor: false) #(#ParseNode #nodePrintOn:indent: false) #(#ParseTreeRewriter #acceptCascadeNode: false) #(#ParseTreeSearcher #messages false) #(#PartsBin #translatedQuads: false) #(#PasteUpMorph #dropFiles: false) #(#PasteUpMorph #mouseDown: false) #(#PhonemeRecord #prunedAverageFeatures: false) #(#PluckedSound #reset false) #(#PluggableDictionary #scanFor: false) #(#PluggableListMorph #list: false) #(#PluggableMultiColumnListMorph #calculateColumnOffsetsFrom: false) #(#PluggableMultiColumnListMorph #calculateColumnWidthsFrom: false) #(#PluggableMultiColumnListMorph #layoutMorphicLists: false) #(#PluggableSet #scanFor: false) #(#PointerFinder #buildList false) #(#PointerFinder #followObject: false) #(#PolygonMorph #derivs:first:second:third: false) #(#PopUpMenu #readKeyboard false) #(#PostscriptCanvas #convertFontName: false) #(#PostscriptCanvas #fontSampler false) #(#PostscriptCanvas #postscriptFontInfoForFont: false) #(#PostscriptCanvas #postscriptFontMappingSummary false) #(#PostscriptCanvas #drawGeneralBezierShape:color:borderWidth:borderColor: false) #(#PostscriptCanvas #outlineQuadraticBezierShape: false) #(#Preferences #keihanna false) #(#Preferences #printStandardSystemFonts false) #(#Preferences #refreshFontSettings false) #(#Preferences #setDefaultFonts: false) #(#Preferences #smallLand false) #(#ProcessBrowser #dumpTallyOnTranscript: false) #(#ProcessBrowser #processNameList false) #(#ProcessorScheduler #highestPriority: false) #(#ProcessorScheduler #nextReadyProcess false) #(#Project #setFlaps false) #(#ProtoObject #pointsTo: false) #(#RBAssignmentNode #bestNodeFor: false) #(#RBFormatter #formatMessage:cascade: false) #(#RBFormatter #formatStatementCommentFor: false) #(#RBMessageNode #bestNodeFor: false) #(#RBPatternMessageNode #receiver:selectorParts:arguments: false) #(#RBPatternVariableNode #initializePatternVariables false) #(#RBProgramNode #copyList:inContext: false) #(#RBSequenceNode #= false) #(#RBSequenceNode #replaceNode:withNodes: false) #(#RemoteHandMorph #appendNewDataToReceiveBuffer false) #(#RunArray #rangeOf:startingAt: false) #(#SARInstaller #ensurePackageWithId: false) #(#SARInstaller #fileIntoChangeSetNamed:fromStream: false) #(#SARInstaller #memberNameForProjectNamed: false) #(#SMLoader #cachePackageReleaseAndOfferToCopy false) #(#SMLoader #downloadPackageRelease false) #(#SMLoader #installPackageRelease: false) #(#SMSqueakMap #accountForName: false) #(#SMSqueakMap #mapInitialsFromMinnow false) #(#SampledSound #convert8bitSignedFrom:to16Bit: false) #(#ScaledDecimalTest #testConvertFromFloat false) #(#ScrollBar #arrowSamples false) #(#ScrollBar #boxSamples false) #(#ScrollBar #doScrollDown false) #(#ScrollBar #doScrollUp false) #(#ScrollBar #scrollDown: false) #(#ScrollBar #scrollUp: false) #(#SecurityManager #flushSecurityKey: false) #(#SelectionMorph #extendByHand: false) #(#SelectorBrowser #markMatchingClasses false) #(#Set #do: false) #(#Set #scanFor: false) #(#ShortIntegerArray #writeOn: false) #(#SimpleMIDIPort #closeAllPorts false) #(#SmaCCParser #errorHandlerStates false) #(#SmaCCParser #findErrorHandlerIfNoneUseErrorNumber: false) #(#SmalltalkImage #saveImageSegments false) #(#SmartRefStream #uniClassInstVarsRefs: false) #(#SoundBuffer #normalized: false) #(#SparseLargeTable #zapDefaultOnlyEntries false) #(#Spline #derivs:first:second:third: false) #(#StrikeFont #bonk:with: false) #(#StrikeFont #buildfontNamed:fromForms:startingAtAscii:ascent:descent:maxWid: false) #(#StrikeFont #makeItalicGlyphs false) #(#StrikeFont #readFromBitFont: false) #(#StrikeFontSet #bonk:with:at: false) #(#StrikeFontSet #displayStringR2L:on:from:to:at:kern: false) #(#StrikeFontSet #makeItalicGlyphs false) #(#String #indexOfAscii:inString:startingAt: false) #(#StringTest #testAsSmalltalkComment false) #(#SymbolTest #testWithFirstCharacterDownshifted false) #(#SyntaxMorph #rename: false) #(#SystemDictionary #makeSqueaklandReleasePhaseFinalSettings false) #(#SystemDictionary #saveImageSegments false) #(#TTCFont #reorganizeForNewFontArray:name: false) #(#TTCFontReader #processCharacterMappingTable: false) #(#TTContourConstruction #segmentsDo: false) #(#TTFontReader #getGlyphFlagsFrom:size: false) #(#TTFontReader #processCharMap: false) #(#TTFontReader #processCharacterMappingTable: false) #(#TTFontReader #processHorizontalMetricsTable:length: false) #(#TestsForTextAndTextStreams #testExampleRunArray5 false) #(#TestsForTextAndTextStreams #testRangeDetection1 false) #(#TestsForTextAndTextStreams #testRangeDetection2 false) #(#TestsForTextAndTextStreams #testRangeDetection3 false) #(#TestsForTextAndTextStreams #testRangeDetection4 false) #(#Text #initTextConstants false) #(#TextConverter #allEncodingNames false) #(#TextStyle #decodeStyleName: false) #(#TextStyle #fontMenuForStyle:target:selector:highlight: false) #(#TextStyle #modalMVCStyleSelectorWithTitle: false) #(#TextStyle #modalStyleSelectorWithTitle: false) #(#TextURL #actOnClickFor: false) #(#ThreePhaseButtonMorph #initialize false) #(#TickIndicatorMorph #drawOn: false) #(#TimeProfileBrowser #setClassAndSelectorIn: false) #(#UCSTable #initializeGB2312Table false) #(#UCSTable #initializeJISX0208Table false) #(#UCSTable #initializeKSX1001Table false) #(#Utilities #decimalPlacesForFloatPrecision: false) #(#Utilities #floatPrecisionForDecimalPlaces: false) #(#WaveEditor #showEnvelope false) #(#WaveletCodec #decodeFrames:from:at:into:at: false) #(#WaveletCodec #encodeFrames:from:at:into:at: false) #(#WeakKeyDictionary #scanFor: false) #(#WeakKeyDictionary #scanForNil: false) #(#WeakSet #scanFor: false) #(#WeakSet #scanForLoadedSymbol: false) #(#WorldState #displayWorldSafely: false) #(#ZLibWriteStream #updateAdler32:from:to:in: false) #(#ZipConstants #initializeDistanceCodes false) #(#ZipWriteStream #dynamicBlockSizeFor:and:using:and: false) #(#ZipWriteStream #fixedBlockSizeFor:and: false) (SimpleMIDIPort closeAllPorts true) (Float initialize true) (FileList2 endingSpec true) (ProcessBrowser dumpTallyOnTranscript: true) (SARInstaller ensurePackageWithId: true) (SARInstaller fileIntoChangeSetNamed:fromStream: true) (Color initializeGrayToIndexMap true) (GIFReadWriter exampleAnim true) (Text initTextConstants true) (String indexOfAscii:inString:startingAt: true)(MultiString indexOfAscii:inString:startingAt: true) (ZLibWriteStream updateAdler32:from:to:in: true) (SampledSound convert8bitSignedFrom:to16Bit: true) (Form dotOfSize: true) (Preferences setDefaultFonts true)(Preferences refreshFontSettings true) (Preferences keihanna true) (Preferences smallLand true) (Preferences printStandardSystemFonts true) (ThreePhaseButtonMorph initialize true)(ScrollBar arrowSamples true) (ScrollBar boxSamples true) (DockingBarMorph example3)(PartsBin translatedQuads: true)(Utilities decimlaPlacesForFloatPrecision: true) (Utilities floatPrecisionForDecimalPlaces: true) (PostcriptCanvas postscriptFontMappingSummary true) (PostscriptCanvas convertFontName: true) (PostscriptCanvas fontSampler true) (PostScriptCanvas postscriptFontInfoForFont: true) (TextStyle decodeStyleName true) (TestStyle fontMenuForStyle:target:selector:highlight: true) (TextStyle modalMVCStyleSelectorWithTitle: true)(TextStyle modalStyleSelectorWithTitle: true) (AbstractFont emphasisStringFor: true) (TTCFonr reorganizeForNewFontArray:name: true) (ZipConstants initializeDistanceCodes true) (MenuIcons createIconMethodsFromDirectory: true) (MenuIcons decorateMenu: true) (UCSTable initializeJISX0208Table true)(UCSTable initializeBG3212Table true)(UCSTable initializeKSX1001Table true) (TextConverter allEncodingNames true))! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 16:07'! decompilerFailures "here is the list of failures: DNU resulting in trying to decompile the following methods" ^ #((PNMReadWriter nextImage) (Collection #ifEmpty:ifNotEmpty:) (Collection #ifEmpty:) (Collection #ifNotEmpty:ifEmpty:) (Text #alignmentAt:ifAbsent:) (ObjectWithDocumentation propertyAt:ifAbsent:)) ! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:36'! decompilerTestHelper "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same. " "self new decompilerTestHelper" | methodNode oldMethod newMethod badOnes oldCodeString n | badOnes := OrderedCollection new. Smalltalk forgetDoIts. 'Decompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n := 0. self systemNavigation allBehaviorsDo: [:cls | (self isBlockingClass: cls) ifFalse: [ Smalltalk garbageCollect. Transcript cr; show: cls name. cls selectors do: [:selector | (n := n + 1) \\ 100 = 0 ifTrue: [bar value: n]. (self isFailure: cls sel: selector) ifFalse: [oldMethod := cls compiledMethodAt: selector. oldCodeString := (cls decompilerClass new decompile: selector in: cls method: oldMethod) decompileString. methodNode := cls compilerClass new compile: oldCodeString in: cls notifying: nil ifFail: []. newMethod := methodNode generate: #(0 0 0 0 ). oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]]]]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:30'! isBlockingClass: cls "self new isBlockingClass: PNMReaderWriter" ^ self blockingClasses includes: cls name asSymbol ! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 15:29'! isFailure: cls sel: selector "self new isKnowProblem: PNMReaderWriter sel: #nextImage" "#((PNMReadWriter nextImage)) includes: {PNMReadWriter name asSymbol . #nextImage}." ^ self decompilerFailures includes: {cls name asSymbol. selector}! ! !DecompilerTests methodsFor: 'utilities' stamp: 'sd 9/25/2004 21:28'! isStoredProblems: cls sel: selector meta: aBoolean "self new isKnowProblem: PNMReaderWriter sel: #nextImage" ^ self decompilerDiscrepancies includes: {cls name asSymbol. selector . aBoolean}! ! !DecompilerTests methodsFor: 'testing' stamp: 'sd 9/26/2004 13:26'! testDecompiler "self run: #testDecompiler" "self debug: #testDecompiler" | methodNode oldMethod newMethod oldCodeString | Smalltalk forgetDoIts. self systemNavigation allBehaviorsDo: [:cls | (self isBlockingClass: cls) ifFalse: [Smalltalk garbageCollect. cls selectors do: [:selector | (self isFailure: cls sel: selector) ifFalse: [" to help making progress (self isStoredProblems: cls theNonMetaClass sel: selector meta: cls isMeta) ifFalse: [ " Transcript cr; show: cls name. oldMethod := cls compiledMethodAt: selector. oldCodeString := (cls decompilerClass new decompile: selector in: cls method: oldMethod) decompileString. methodNode := cls compilerClass new compile: oldCodeString in: cls notifying: nil ifFail: []. newMethod := methodNode generate: #(0 0 0 0 ). self assert: oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString description: cls name asString, ' ', selector asString resumable: true. ]]]]! ! !DecompilerTests commentStamp: 'sd 9/26/2004 13:24' prior: 0! Apparently the decompiler does not really work totally. Here are a bunch of methods that can help improving the decompiler: - blockingClasses return class for which it is impossible to decompile methods - failures are problems that lead to a DNU - decompilerDiscrepancies are the results of running decompileTestHelper..as you see the pattern is quite present.! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 10/4/2001 13:54'! checkBasicClasses "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | str str2 objCls morphCls playerCls | str _ '|veryDeepCopyWith: or veryDeepInner: is out of date.'. (objCls _ self objInMemory: #Object) ifNotNil: [ objCls instSize = 0 ifFalse: [self error: 'Many implementers of veryDeepCopyWith: are out of date']]. (morphCls _ self objInMemory: #Morph) ifNotNil: [ morphCls superclass == Object ifFalse: [self error: 'Morph', str]. (morphCls instVarNames copyFrom: 1 to: 6) = #('bounds' 'owner' 'submorphs' 'fullBounds' 'color' 'extension') ifFalse: [self error: 'Morph', str]]. "added ones are OK" str2 _ 'Player|copyUniClassWith: and DeepCopier|mapUniClasses are out of date'. (playerCls _ self objInMemory: #Player) ifNotNil: [ playerCls class instVarNames = #('scripts' 'slotInfo') ifFalse: [self error: str2]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:42'! checkClass: aClass | meth | "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it." self checkBasicClasses. "Unlikely, but important to catch when it does happen." "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (aClass includesSelector: #veryDeepInner:) ifTrue: [ ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [ aClass instSize > 0 ifTrue: [ self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ meth _ aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:52'! checkDeep "Write exceptions in the Transcript. Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. This check is only run by hand once in a while to make sure nothing was forgotten. (Please do not remove this method.) DeepCopier new checkDeep " | mm | Transcript cr; show: 'Instance variables shared with the original object when it is copied'. (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | (mm := aClass instVarNames size) > 0 ifTrue: [aClass instSize - mm + 1 to: aClass instSize do: [:index | ((aClass compiledMethodAt: #veryDeepInner:) writesField: index) ifFalse: [Transcript cr; show: aClass name; space; show: (aClass allInstVarNames at: index)]]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'dvf 8/23/2003 11:53'! checkVariables "Check that no indexes of instance vars have changed in certain classes. If you get an error in this method, an implementation of veryDeepCopyWith: needs to be updated. The idea is to catch a change while it is still in the system of the programmer who made it. DeepCopier new checkVariables " | meth | self checkBasicClasses. "Every class that implements veryDeepInner: must copy all its inst vars. Danger is that a user will add a new instance variable and forget to copy it. So check that the last one is mentioned in the copy method." (self systemNavigation allClassesImplementing: #veryDeepInner:) do: [:aClass | ((aClass compiledMethodAt: #veryDeepInner:) writesField: aClass instSize) ifFalse: [aClass instSize > 0 ifTrue: [self warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (self systemNavigation allClassesImplementing: #veryDeepCopyWith:) do: [:aClass | meth := aClass compiledMethodAt: #veryDeepCopyWith:. meth size > 20 & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [(meth writesField: aClass instSize) ifFalse: [self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 13:56'! fixDependents "They are not used much, but need to be right" | newDep newModel | DependentsFields associationsDo: [:pair | pair value do: [:dep | newDep _ references at: dep ifAbsent: [nil]. newDep ifNotNil: [ newModel _ references at: pair key ifAbsent: [pair key]. newModel addDependent: newDep]]]. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:40'! initialize: size references _ IdentityDictionary new: size. uniClasses _ IdentityDictionary new. "UniClass -> new UniClass" "self isItTimeToCheckVariables ifTrue: [self checkVariables]." "no more checking at runtime" newUniClasses _ true.! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:14'! mapUniClasses "For new Uniclasses, map their class vars to the new objects. And their additional class instance vars. (scripts slotInfo) and cross references like (player321)." "Players also refer to each other using associations in the References dictionary. Search the methods of our Players for those. Make new entries in References and point to them." | pp oldPlayer newKey newAssoc oldSelList newSelList | newUniClasses ifFalse: [^ self]. "All will be siblings. uniClasses is empty" "Uniclasses use class vars to hold onto siblings who are referred to in code" pp _ Player class superclass instSize. uniClasses do: [:playersClass | "values = new ones" playersClass classPool associationsDo: [:assoc | assoc value: (assoc value veryDeepCopyWith: self)]. playersClass scripts: (playersClass privateScripts veryDeepCopyWith: self). "pp+1" "(pp+2) slotInfo was deepCopied in copyUniClass and that's all it needs" pp+3 to: playersClass class instSize do: [:ii | playersClass instVarAt: ii put: ((playersClass instVarAt: ii) veryDeepCopyWith: self)]. ]. "Make new entries in References and point to them." References keys "copy" do: [:playerName | oldPlayer _ References at: playerName. (references includesKey: oldPlayer) ifTrue: [ newKey _ (references at: oldPlayer) "new player" uniqueNameForReference. "now installed in References" (references at: oldPlayer) renameTo: newKey]]. uniClasses "values" do: [:newClass | oldSelList _ OrderedCollection new. newSelList _ OrderedCollection new. newClass selectorsDo: [:sel | (newClass compiledMethodAt: sel) literals do: [:assoc | assoc isVariableBinding ifTrue: [ (References associationAt: assoc key ifAbsent: [nil]) == assoc ifTrue: [ newKey _ (references at: assoc value ifAbsent: [assoc value]) externalName asSymbol. (assoc key ~= newKey) & (References includesKey: newKey) ifTrue: [ newAssoc _ References associationAt: newKey. newClass methodDictionary at: sel put: (newClass compiledMethodAt: sel) clone. "were sharing it" (newClass compiledMethodAt: sel) literalAt: ((newClass compiledMethodAt: sel) literals indexOf: assoc) put: newAssoc. (oldSelList includes: assoc key) ifFalse: [ oldSelList add: assoc key. newSelList add: newKey]]]]]]. oldSelList with: newSelList do: [:old :new | newClass replaceSilently: old to: new]]. "This is text replacement and can be wrong"! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/11/2003 14:13'! newUniClasses "If false, all new Players are merely siblings of the old players" ^ newUniClasses! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/4/2003 19:44'! newUniClasses: newVal "If false, all new players are merely siblings of the old players" newUniClasses _ newVal! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:29'! objInMemory: ClassSymbol | cls | "Test if this global is in memory and return it if so." cls _ Smalltalk at: ClassSymbol ifAbsent: [^ nil]. ^ cls isInMemory ifTrue: [cls] ifFalse: [nil].! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 3/7/2001 15:46'! warnIverNotCopiedIn: aClass sel: sel "Warn the user to update veryDeepCopyWith: or veryDeepInner:" self inform: ('An instance variable was added to to class ', aClass name, ',\and it is not copied in the method ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs. Browser openMessageBrowserForClass: aClass selector: sel editString: nil. ! ! !DeepCopier commentStamp: 'tk 3/4/2003 19:39' prior: 0! DeepCopier does a veryDeepCopy. It is a complete tree copy using a dictionary. Any object that is in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. See Object|veryDeepCopy which calls (self veryDeepCopyWith: aDeepCopier). The dictionary of objects that have been seen, holds the correspondance (uniClass -> new uniClass). When a tree of morphs points at a morph outside of itself, that morph should not be copied. Use our own kind of weak pointers for the 'potentially outside' morphs. Default is that any new class will have all of its fields deeply copied. If a field needs to be weakly copied, define veryDeepInner: and veryDeepFixupWith:. veryDeepInner: has the loop that actually copies the fields. If a class defines its own copy of veryDeepInner: (to leave some fields out), then veryDeepFixupWith: will be called on that object at the end. veryDeepInner: can compute an alternate object to put in a field. (Object veryDeepCopyWith: discovers which superclasses did not define veryDeepInner:, and very deeply copies the variables defined in those classes). To decide if a class needs veryDeepInner: and veryDeepFixupWith:, ask this about an instance: If I duplicate this object, does that mean that I also want to make duplicates of the things it holds onto? If yes, (i.e. a Paragraph does want a new copy of its Text) then do nothing. If no, (i.e. an undo command does not want to copy the objects it acts upon), then define veryDeepInner: and veryDeepFixupWith:. Here is an analysis for the specific case of a morph being held by another morph. Does field X contain a morph (or a Player whose costume is a morph)? If not, no action needed. Is the morph in field X already a submorph of the object? Is it down lower in the submorph tree? If so, no action needed. Could the morph in field X every appear on the screen (be a submorph of some other morph)? If not, no action needed. If it could, you must write the methods veryDeepFixupWith: and veryDeepInner:, and in them, refrain from sending veryDeepCopyWith: to the contents of field X. newUniClasses = true in the normal case. Every duplicated Player gets a new class. When false, all duplicates will be siblings (sister instances) of existing players. ----- Things Ted is still considering ----- Rule: If a morph stores a uniClass class (Player 57) as an object in a field, the new uniClass will not be stored there. Each uniClass instance does have a new class created for it. (fix this by putting the old class in references and allow lookup? Wrong if encounter it before seeing an instance?) Rule: If object A has object C in a field, and A says (^ C) for the copy, but object B has A in a normal field and it gets deepCopied, and A in encountered first, then there will be two copies of C. (just be aware of it) Dependents are now fixed up. Suppose a model has a dependent view. In the DependentFields dictionary, model -> (view ...). If only the model is copied, no dependents are created (no one knows about the new model). If only the view is copied, it is inserted into DependentFields on the right side. model -> (view copiedView ...). If both are copied, the new model has the new view as its dependent. If additional things depend on a model that is copied, the caller must add them to its dependents. ! !DefaultExternalDropHandler methodsFor: 'event handling' stamp: 'bf 9/21/2004 18:44'! handle: dropStream in: pasteUp dropEvent: anEvent "the file was just droped, let's do our job" | fileName services theOne | fileName := dropStream name. "" services := self servicesForFileNamed: fileName. "" "no service, default behavior" services isEmpty ifTrue: ["" dropStream edit. ^ self]. "" theOne := self chooseServiceFrom: services. theOne isNil ifFalse: [theOne performServiceFor: dropStream]! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 20:53'! chooseServiceFrom: aCollection "private - choose a service from aCollection asking the user if needed" | menu | aCollection size = 1 ifTrue: [^ aCollection anyOne]. "" menu := CustomMenu new. aCollection do: [:each | menu add: each label action: each]. ^ menu startUp! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'! servicesForFileNamed: aString "private - answer a collection of file-services for the file named aString" | allServices | allServices := FileList itemsForFile: aString. ^ allServices reject: [:svc | self unwantedSelectors includes: svc selector]! ! !DefaultExternalDropHandler methodsFor: 'private' stamp: 'dgd 4/5/2004 19:23'! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! !DefaultExternalDropHandler commentStamp: 'dgd 4/5/2004 19:07' prior: 0! An alternative default handler that uses the file-list services to process files. ! !DefaultExternalDropHandler class methodsFor: 'class initialization' stamp: 'dgd 4/5/2004 19:10'! initialize "initialize the receiver" ExternalDropHandler defaultHandler: self new! ! !DefaultExternalDropHandler class methodsFor: 'class initialization' stamp: 'dgd 4/5/2004 19:09'! unload "initialize the receiver" ExternalDropHandler defaultHandler: nil! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 2/19/2004 00:34'! next: bytes putAll: aCollection startingAt: startPos (startPos = 1 and:[bytes = aCollection size]) ifTrue:[^self nextPutAll: aCollection]. ^self nextPutAll: (aCollection copyFrom: startPos to: startPos + bytes - 1)! ! !Delay methodsFor: 'delaying' stamp: 'nk 3/14/2001 08:52'! isExpired ^delaySemaphore isSignaled. ! ! !Delay methodsFor: 'private' stamp: 'ar 7/18/2001 20:28'! activate "Private!! Make the receiver the Delay to be awoken when the next timer interrupt occurs. This method should only be called from a block protected by the AccessProtect semaphore." ActiveDelay _ self. ActiveDelayStartTime _ Time millisecondClockValue. ActiveDelayStartTime > resumptionTime ifTrue:[ ActiveDelay signalWaitingProcess. SuspendedDelays isEmpty ifTrue:[ ActiveDelay _ nil. ActiveDelayStartTime _ nil. ] ifFalse:[SuspendedDelays removeFirst activate]. ] ifFalse:[ TimingSemaphore initSignals. Delay primSignal: TimingSemaphore atMilliseconds: resumptionTime. ].! ! !Delay methodsFor: 'public' stamp: 'brp 10/21/2004 16:05'! delaySemaphore ^ delaySemaphore! ! !Delay commentStamp: 'ls 10/14/2003 11:46' prior: 0! I am the main way that a process may pause for some amount of time. The simplest usage is like this: (Delay forSeconds: 5) wait. An instance of Delay responds to the message 'wait' by suspending the caller's process for a certain amount of time. The duration of the pause is specified when the Delay is created with the message forMilliseconds: or forSeconds:. A Delay can be used again when the current wait has finished. For example, a clock process might repeatedly wait on a one-second Delay. The maximum delay is (SmallInteger maxVal // 2) milliseconds, or about six days. A delay in progress when an image snapshot is saved is resumed when the snapshot is re-started. Delays work across millisecond clock roll-overs. For a more complex example, see #testDelayOf:for:rect: .! ]style[(763 22 2)f1,f1LDelay class testDelayOf:for:rect:;,f1! !Delay class methodsFor: 'instance creation' stamp: 'brp 9/25/2003 13:43'! forDuration: aDuration ^ self forMilliseconds: aDuration asMilliSeconds ! ! !Delay class methodsFor: 'instance creation' stamp: 'dtl 12/11/2004 11:59'! forMilliseconds: anInteger "Return a new Delay for the given number of milliseconds. Sending 'wait' to this Delay will cause the sender's process to be suspended for approximately that length of time." anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. ^ self new setDelay: anInteger asInteger forSemaphore: Semaphore new ! ! !Delay class methodsFor: 'testing'! nextWakeUpTime ^ AccessProtect critical: [ActiveDelay isNil ifTrue: [0] ifFalse: [ActiveDelay resumptionTime]]! ! !DependentsArray methodsFor: 'copying' stamp: 'ar 2/24/2001 17:30'! copyWith: newElement "Re-implemented to not copy any niled out dependents" ^self class streamContents:[:s| self do:[:item| s nextPut: item]. s nextPut: newElement].! ! !DependentsArray methodsFor: 'copying' stamp: 'nk 3/11/2004 09:34'! size ^self inject: 0 into: [ :count :dep | dep ifNotNil: [ count _ count + 1 ]]! ! !DependentsArray methodsFor: 'enumerating' stamp: 'nk 3/11/2004 09:34'! do: aBlock "Refer to the comment in Collection|do:." | dep | 1 to: self basicSize do:[:i| (dep _ self at: i) ifNotNil:[aBlock value: dep]].! ! !DependentsArray methodsFor: 'enumerating' stamp: 'ar 2/11/2001 01:50'! select: aBlock "Refer to the comment in Collection|select:." | aStream | aStream _ WriteStream on: (self species new: self size). self do:[:obj| (aBlock value: obj) ifTrue: [aStream nextPut: obj]]. ^ aStream contents! ! !DependentsArray commentStamp: '' prior: 0! An array of (weak) dependents of some object.! !Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! This Warning is signalled by methods which are deprecated. The use of Object>>#deprecatedExplanation: aString and Object>>#deprecated: aBlock explanation: aString is recommended. Idiom: Imagine I want to deprecate the message #foo. foo ^ 'foo' I can replace it with: foo self deprecatedExplanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ^ 'foo' Or, for certain cases such as when #foo implements a primitive, #foo can be renamed to #fooDeprecated. fooDeprecated ^ foo ^ self deprecated: [self fooDeprecated] explanation: 'The method #foo was not good. Use Bar>>newFoo instead.' ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! categories "Answer the categoryList of the receiver" ^ categoryList! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! documentation "Answer the documentation of the receiver" ^ documentation! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! formalName "Answer the formalName of the receiver" ^ formalName! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! globalReceiverSymbol "Answer the globalReceiverSymbol of the receiver" ^ globalReceiverSymbol! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'sw 8/10/2001 14:38'! nativitySelector "Answer the nativitySelector of the receiver" ^ nativitySelector! ! !DescriptionForPartsBin methodsFor: 'access' stamp: 'dgd 9/2/2003 18:57'! translatedCategories "Answer translated the categoryList of the receiver" ^ self categories collect: [:each | each translated]! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 8/2/2001 01:04'! formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel "Set all of the receiver's instance variables from the parameters provided" formalName _ aName. categoryList _ aList. documentation _ aDoc. globalReceiverSymbol _ aSym. nativitySelector _ aSel! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 16:52'! sampleImageForm "If I have a sample image form override stored, answer it, else answer one obtained by launching an actual instance" ^ sampleImageForm ifNil: [((Smalltalk at: globalReceiverSymbol) perform: nativitySelector) imageFormDepth: 32]! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 10/24/2001 16:37'! sampleImageForm: aForm "Set the sample image form" sampleImageForm _ aForm! ! !DescriptionForPartsBin methodsFor: 'initialization' stamp: 'sw 11/27/2001 13:19'! sampleImageFormOrNil "If I have a sample image form override stored, answer it, dlse answer nil" ^ sampleImageForm ! ! !DescriptionForPartsBin methodsFor: 'printing' stamp: 'sw 8/10/2001 21:48'! printOn: aStream aStream nextPutAll: 'a DescriptionForPartsBin, with categoryList=', categoryList asString, ' docmentation=', documentation asString, ' globalReceiverSymbol=', globalReceiverSymbol asString, ' nativitySelector=', nativitySelector asString ! ! !DescriptionForPartsBin commentStamp: '' prior: 0! An object description, for use with the ObjectsTool and other parts-bin-like repositories. formalName The formal name by which the object is to be known categoryList A list of category symbols, by way of attribute tags documentation For use in balloon help, etc. globalReceiverSymbol A symbol representing the global to whom to send nativitySelector nativitySelector The selector to send to the global receiver to obtain a new instance! !DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 14:39'! formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel "Answer a new instance of the receiver with the given traits" ^ self new formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: aSym nativitySelector: aSel! ! !DescriptionForPartsBin class methodsFor: 'instance creation' stamp: 'sw 8/10/2001 22:33'! fromQuad: aQuad categoryList: aList "Answer an instance of DescriptionForPartsBin from the part-defining quad provided" ^ self formalName: aQuad third categoryList: aList documentation: aQuad fourth globalReceiverSymbol: aQuad first nativitySelector: aQuad second! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:12'! messagePart: level repeat: repeat initialKeyword: kwdIfAny | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (self matchKeyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). selector nextPutAll: kwdIfAny. args _ OrderedCollection new. words _ OrderedCollection new. [self matchKeyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance , ':'. words addLast: (keywordStart to: hereEnd + requestorOffset). self primaryExpression ifFalse: [^ self expected: 'Argument']. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [(hereType == #word and: [(#(leftParenthesis leftBracket leftBrace) includes: tokenType) not]) ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! ! !DialectParser methodsFor: 'as yet unclassified' stamp: 'hmm 7/16/2001 20:09'! temporaries " [ 'Use' (variable)* '.' ]" | vars theActualText | (self matchToken: #'Use') ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ prevEnd+1. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #period) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Period'! ! !DialectParser class methodsFor: 'as yet unclassified' stamp: 'dvf 8/23/2003 12:17'! test "DialectParser test" "PrettyPrints the source for every method in the system in the alternative syntax, and then compiles that source and verifies that it generates identical code. No changes are actually made to the system. At the time of this writing, only two methods caused complaints (reported in Transcript and displayed in browse window after running): BalloonEngineSimulation circleCosTable and BalloonEngineSimulation circleSinTable. These are not errors, but merely a case of Floats embedded in literal arrays, and thus not specially checked for roundoff errors. Note that if an error or interruption occurs during execution of this method, the alternativeSyntax preference will be left on. NOTE: Some methods may not compare properly until the system has been recompiled once. Do this by executing... Smalltalk recompileAllFrom: 'AARDVAARK'. " | newCodeString methodNode oldMethod newMethod badOnes n heading | Preferences enable: #printAlternateSyntax. badOnes _ OrderedCollection new. Transcript clear. Smalltalk forgetDoIts. 'Formatting and recompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allClassesDo: "{MethodNode} do:" "<- to check one class" [:nonMeta | "Transcript cr; show: nonMeta name." {nonMeta. nonMeta class} do: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. heading _ cls organization categoryOfElement: selector. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: (SyntaxError new category: heading) ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. "Transcript cr; show: cls name , ' ' , selector." oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. oldMethod size = newMethod size ifFalse: [Transcript show: ' difft size']. oldMethod header = newMethod header ifFalse: [Transcript show: ' difft header']. oldMethod literals = newMethod literals ifFalse: [Transcript show: ' difft literals']. Transcript endEntry. badOnes add: cls name , ' ' , selector]]]]. ]. self systemNavigation browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'. Preferences disable: #printAlternateSyntax. ! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:20'! colorTable "Answer the table to use to determine colors" ^ colorTable ifNil: [colorTable _ dialect == #SQ00 ifTrue: [Sq00ColorTable] ifFalse: [ST80ColorTable]]! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 21:05'! withColor: colorSymbol emphasis: emphasisSymbol do: aBlock "Evaluate the given block with the given color and style text attribute" ^ self withAttributes: {TextColor color: (Color perform: colorSymbol). TextEmphasis perform: emphasisSymbol} do: aBlock! ! !DialectStream methodsFor: 'color/style' stamp: 'sw 5/20/2001 11:30'! withStyleFor: elementType do: aBlock "Evaluate aBlock with appropriate emphasis and color for the given elementType" | colorAndStyle | colorAndStyle _ self colorTable at: elementType. ^ self withColor: colorAndStyle first emphasis: colorAndStyle second do: aBlock! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:27'! initialize "Initialize the color tables" self initializeST80ColorTable. self initializeSq00ColorTable. "DialectStream initialize" ! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 21:09'! initializeST80ColorTable "Initiialize the colors that characterize the ST80 dialect" ST80ColorTable _ IdentityDictionary new. #( (temporaryVariable blue italic) (methodArgument blue normal) (methodSelector black bold) (blockArgument red normal) (comment brown normal) (variable magenta normal) (literal tan normal) (keyword darkGray bold) (prefixKeyword veryDarkGray bold) (setOrReturn black bold)) do: [:aTriplet | ST80ColorTable at: aTriplet first put: aTriplet allButFirst] "DialectStream initialize"! ! !DialectStream class methodsFor: 'class initialization' stamp: 'sw 5/20/2001 11:25'! initializeSq00ColorTable "Initiialize the colors that characterize the Sq00 dialect" Sq00ColorTable _ IdentityDictionary new. #( (temporaryVariable black normal) (methodArgument black normal) (methodSelector black bold) (blockArgument black normal) (comment brown normal) (variable black normal) (literal blue normal) (keyword darkGray bold) (prefixKeyword veryDarkGray bold) (setOrReturn black bold)) do: [:aTriplet | Sq00ColorTable at: aTriplet first put: aTriplet allButFirst]! ! !DialectStream class methodsFor: 'instance creation' stamp: 'sw 5/20/2001 21:07'! dialect: dialectSymbol contents: blockWithArg "Evaluate blockWithArg on a DialectStream of the given description" | stream | stream _ self on: (Text new: 400). stream setDialect: dialectSymbol. blockWithArg value: stream. ^ stream contents! ! !Dictionary methodsFor: 'accessing' stamp: 'dvf 9/17/2003 16:03'! associations "Answer a Collection containing the receiver's associations." | out | out _ WriteStream on: (Array new: self size). self associationsDo: [:value | out nextPut: value]. ^ out contents! ! !Dictionary methodsFor: 'accessing' stamp: 'di 3/7/2001 15:29'! at: key ifPresentAndInMemory: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." | v | v _ self at: key ifAbsent: [^ nil]. v isInMemory ifFalse: [^ nil]. ^ aBlock value: v ! ! !Dictionary methodsFor: 'testing' stamp: 'tween 9/13/2004 10:11'! hasBindingThatBeginsWith: aString "Answer true if the receiver has a key that begins with aString, false otherwise" self keysDo:[:each | (each beginsWith: aString) ifTrue:[^true]]. ^false! ! !Dictionary methodsFor: 'testing' stamp: 'ab 9/17/2004 00:39'! includesAssociation: anAssociation ^ (self associationAt: anAssociation key ifAbsent: [ ^ false ]) value = anAssociation value ! ! !Dictionary methodsFor: 'testing' stamp: 'RAA 8/23/2001 12:56'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." self at: key ifAbsent: [^false]. ^true! ! !Dictionary methodsFor: 'adding' stamp: 'raok 12/17/2003 16:01'! addAll: aKeyedCollection aKeyedCollection == self ifFalse: [ aKeyedCollection keysAndValuesDo: [:key :value | self at: key put: value]]. ^aKeyedCollection! ! !Dictionary methodsFor: 'removing' stamp: 'dvf 8/23/2003 11:51'! unreferencedKeys "TextConstants unreferencedKeys" | n | ^'Scanning for references . . .' displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | n := 0. self keys select: [:key | bar value: (n := n + 1). (self systemNavigation allCallsOn: (self associationAt: key)) isEmpty]]! ! !Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:40'! associationsSelect: aBlock "Evaluate aBlock with each of my associations as the argument. Collect into a new dictionary, only those associations for which aBlock evaluates to true." | newCollection | newCollection _ self species new. self associationsDo: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^newCollection! ! !Dictionary methodsFor: 'enumerating' stamp: 'dtl 2/17/2003 09:48'! valuesDo: aBlock "Evaluate aBlock for each of the receiver's values." self associationsDo: [:association | aBlock value: association value]! ! !Dictionary methodsFor: 'printing' stamp: 'apb 7/14/2004 12:48'! printElementsOn: aStream aStream nextPut: $(. self size > 100 ifTrue: [aStream nextPutAll: 'size '. self size printOn: aStream] ifFalse: [self keysSortedSafely do: [:key | aStream print: key; nextPutAll: '->'; print: (self at: key); space]]. aStream nextPut: $)! ! !Dictionary methodsFor: 'private' stamp: 'raok 4/22/2002 12:09'! copy "Must copy the associations, or later store will affect both the original and the copy" ^ self shallowCopy withArray: (array collect: [:assoc | assoc ifNil: [nil] ifNotNil: [Association key: assoc key value: assoc value]])! ! !Dictionary methodsFor: 'user interface' stamp: 'hg 10/3/2001 20:47'! explorerContents | contents | contents _ OrderedCollection new. self keysSortedSafely do: [:key | contents add: (ObjectExplorerWrapper with: (self at: key) name: (key printString contractTo: 32) model: self)]. ^contents ! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:07'! bindingOf: varName ^self associationAt: varName ifAbsent:[nil]! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33'! bindingsDo: aBlock ^self associationsDo: aBlock! ! !Dictionary methodsFor: 'comparing' stamp: 'md 10/17/2004 16:14'! = aDictionary "Two dictionaries are equal if (a) they are the same 'kind' of thing. (b) they have the same set of keys. (c) for each (common) key, they have the same value" self == aDictionary ifTrue: [ ^ true ]. (aDictionary isKindOf: Dictionary) ifFalse: [^false]. self size = aDictionary size ifFalse: [^false]. self associationsDo: [:assoc| (aDictionary at: assoc key ifAbsent: [^false]) = assoc value ifFalse: [^false]]. ^true ! ! !Dictionary methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:18'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^ DictionaryInspector! ! !Dictionary commentStamp: '' prior: 0! I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a container of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key. I inherit many operations from Set.! !DictionaryInspector methodsFor: 'accessing' stamp: 'apb 8/20/2004 23:06'! fieldList ^ self baseFieldList , (keyArray collect: [:key | key printString])! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 21:41'! addEntry: aKey object at: aKey put: nil. self calculateKeyArray. selectionIndex _ self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 23:23'! refreshView | i | i _ selectionIndex. self calculateKeyArray. selectionIndex _ i. self changed: #fieldList. self changed: #contents.! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:37'! replaceSelectionValue: anObject selectionIndex <= self numberOfFixedFields ifTrue: [^ super replaceSelectionValue: anObject]. ^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) put: anObject! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 21:55'! selection selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection]. ^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent:[nil]! ! !DictionaryInspector methodsFor: 'private' stamp: 'apb 8/20/2004 21:15'! numberOfFixedFields ^ 2 + object class instSize! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:41'! addEntry | newKey aKey | newKey _ FillInTheBlank request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4'. aKey _ Compiler evaluate: newKey. object at: aKey put: nil. self calculateKeyArray. selectionIndex _ self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:19'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1)." | sel | self selectionIndex <= self numberOfFixedFields ifTrue: [super copyName] ifFalse: [sel := String streamContents: [:strm | strm nextPutAll: '(self at: '. (keyArray at: selectionIndex - self numberOfFixedFields) storeOn: strm. strm nextPutAll: ')']. Clipboard clipboardText: sel asText "no undo allowed"]! ! !DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:25'! fieldListMenu: aMenu ^ aMenu labels: 'inspect copy name references objects pointing to this value senders of this key refresh view add key rename key remove basic inspect' lines: #(6 9) selections: #(inspectSelection copyName selectionReferences objectReferencesToSelection sendersOfSelectedKey refreshView addEntry renameEntry removeSelection inspectBasic) ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:39'! removeSelection selectionIndex = 0 ifTrue: [^ self changed: #flash]. object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). selectionIndex _ 0. contents _ ''. self calculateKeyArray. self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self changed: #selection.! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:38'! renameEntry | newKey aKey value | value _ object at: (keyArray at: selectionIndex - self numberOfFixedFields). newKey _ FillInTheBlank request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4' initialAnswer: (keyArray at: selectionIndex - self numberOfFixedFields) printString. aKey _ Compiler evaluate: newKey. object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). object at: aKey put: value. self calculateKeyArray. selectionIndex _ self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #selectionIndex. self changed: #inspectObject. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:26'! selectionReferences "Create a browser on all references to the association of the current selection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex - self numberOfFixedFields)). ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:30'! sendersOfSelectedKey "Create a browser on all senders of the selected key" | aKey | self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((aKey := keyArray at: selectionIndex - self numberOfFixedFields) isKindOf: Symbol) ifFalse: [^ self changed: #flash]. SystemNavigation default browseAllCallsOn: aKey! ! !DictionaryInspector methodsFor: 'initialize-release' stamp: 'PHK 7/21/2004 18:00'! initialize super initialize. self calculateKeyArray! ! !DictionaryTest methodsFor: 'testing' stamp: 'sd 12/17/2003 20:31'! testAddAll "(self run: #testAddAll)" | dict1 dict2 | dict1 := Dictionary new. dict1 at: #a put:1 ; at: #b put: 2. dict2 := Dictionary new. dict2 at: #a put: 3 ; at: #c put: 4. dict1 addAll: dict2. self assert: (dict1 at: #a) = 3. self assert: (dict1 at: #b) = 2. self assert: (dict1 at: #c) = 4.! ! !DictionaryTest methodsFor: 'testing' stamp: 'md 10/1/2004 11:25'! testAssociationsSelect "(self selector: #testAssociationsSelect) run" | answer d| d _ Dictionary new. d at: (Array with: #hello with: #world) put: #fooBar. d at: Smalltalk put: #'Smalltalk is the key'. d at: #Smalltalk put: Smalltalk. answer _ d associationsSelect: [:assoc | (assoc key == #Smalltalk) and: [assoc value == Smalltalk]]. self should: [answer isKindOf: Dictionary]. self should: [answer size == 1]. self should: [(answer at: #Smalltalk) == Smalltalk]. answer _ d associationsSelect: [:assoc | (assoc key == #NoSuchKey) and: [assoc value == #NoSuchValue]]. self should: [answer isKindOf: Dictionary]. self should: [answer size == 0]! ! !DictionaryTest methodsFor: 'testing' stamp: 'sd 12/17/2003 20:30'! testComma "(self run: #testComma)" | dict1 dict2 dict3 | dict1 := Dictionary new. dict1 at: #a put:1 ; at: #b put: 2. dict2 := Dictionary new. dict2 at: #a put: 3 ; at: #c put: 4. dict3 := dict1, dict2. self assert: (dict3 at: #a) = 3. self assert: (dict3 at: #b) = 2. self assert: (dict3 at: #c) = 4.! ! !DictionaryTest methodsFor: 'testing' stamp: 'ab 9/17/2004 00:43'! testIncludesAssociation "self debug: #testIncludesAssociation" | d | d := Dictionary new at: #five put: 5; at: #givemefive put: 5; at: #six put: 6; yourself. self assert: (d includesAssociation: (d associationAt: #five)). self assert: (d includesAssociation: (#five -> 5)). self assert: (d includesAssociation: (#five -> 6)) not.! ! !DiffusionTurtle methodsFor: 'demons' stamp: 'jm 3/3/2001 13:04'! bounce (self turtleCountHere > 1) ifTrue: [ self turnRight: 180 + (self random: 45). self turnLeft: (self random: 45)]. ! ! !DiffusionTurtle methodsFor: 'demons' stamp: 'jm 2/5/2001 19:32'! move self forward: 1. ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'ar 2/1/2001 20:18'! initRandomFromString: aString "Ask the user to type a long random string and use the result to seed the secure random number generator." | s k srcIndex | s _ aString. k _ LargePositiveInteger new: (s size min: 64). srcIndex _ 0. k digitLength to: 1 by: -1 do: [:i | k digitAt: i put: (s at: (srcIndex _ srcIndex + 1)) asciiValue]. k _ k + (Random new next * 16r7FFFFFFF) asInteger. "a few additional bits randomness" k highBit > 512 ifTrue: [k _ k bitShift: k highBit - 512]. self initRandom: k. ! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'gk 2/26/2004 09:52'! initRandomNonInteractively [self initRandom: (SoundService default randomBitsFromSoundInput: 512)] ifError: [self initRandomFromString: Time millisecondClockValue printString, Date today printString, SmalltalkImage current platformName printString].! ! !DigitalSignatureAlgorithm class methodsFor: 'public' stamp: 'ads 7/31/2003 14:01'! generateKeySet "Generate and answer a key set for code signing. The result is a pair (). Each key is an array of four large integers. The signer must be sure to record this keys set and must keep the private key secret to prevent someone from forging their signature." "Note: Key generation can take some time. Open a transcript so you can see what's happening and take a coffee break!!" "Note: Unguessable random numbers are needed for key generation. The user will be prompted to type a really long random string (two or three lines) to initialize the random number generator before generating a key set. A different random string should be typed for every session; it is not a password and we wish to produce different random number streams." "DigitalSignatureAlgorithm generateKeySet" | dsa | dsa _ DigitalSignatureAlgorithm new. (self confirm: 'Shall I seed the random generator from the current sound input?') ifTrue: [dsa initRandomNonInteractively] ifFalse: [dsa initRandomFromUser]. ^ dsa generateKeySet ! ! !DirectoryEntry methodsFor: 'multilingual system' stamp: 'yo 12/20/2003 01:56'! convertFromSystemName name _ (FilePath pathName: name isEncoded: true) asSqueakPathName! ! !DiskProxy methodsFor: 'as yet unclassified' stamp: 'yo 11/14/2002 15:23'! comeFullyUpOnReload: smartRefStream "Internalize myself into a fully alive object after raw loading from a DataStream. (See my class comment.) DataStream will substitute the object from this eval for the DiskProxy." | globalObj symbol pr nn arrayIndex | symbol _ globalObjectName. "See if class is mapped to another name" (smartRefStream respondsTo: #renamed) ifTrue: [ "If in outPointers in an ImageSegment, remember original class name. See mapClass:installIn:. Would be lost otherwise." ((thisContext sender sender sender sender sender sender sender sender receiver class == ImageSegment) and: [ thisContext sender sender sender sender method == (DataStream compiledMethodAt: #readArray)]) ifTrue: [ arrayIndex _ (thisContext sender sender sender sender) tempAt: 4. "index var in readArray. Later safer to find i on stack of context." smartRefStream renamedConv at: arrayIndex put: symbol]. "save original name" symbol _ smartRefStream renamed at: symbol ifAbsent: [symbol]]. "map" globalObj _ Smalltalk at: symbol ifAbsent: [ preSelector == nil & (constructorSelector = #yourself) ifTrue: [ Transcript cr; show: symbol, ' is undeclared.'. (Undeclared includesKey: symbol) ifTrue: [^ Undeclared at: symbol]. Undeclared at: symbol put: nil. ^ nil]. ^ self error: 'Global "', symbol, '" not found']. ((symbol == #World) and: [Smalltalk isMorphic not]) ifTrue: [ self inform: 'These objects will work better if opened in a Morphic World. Dismiss and reopen all menus.']. preSelector ifNotNil: [ Symbol hasInterned: preSelector ifTrue: [:selector | [globalObj _ globalObj perform: selector] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal]] ]. symbol == #Project ifTrue: [ (constructorSelector = #fromUrl:) ifTrue: [ nn _ (constructorArgs first findTokens: '/') last. nn _ (nn findTokens: '.|') first. pr _ Project named: nn. ^ pr ifNil: [self] ifNotNil: [pr]]. pr _ globalObj perform: constructorSelector withArguments: constructorArgs. ^ pr ifNil: [self] ifNotNil: [pr]]. "keep the Proxy if Project does not exist" constructorSelector ifNil: [^ globalObj]. Symbol hasInterned: constructorSelector ifTrue: [:selector | [^ globalObj perform: selector withArguments: constructorArgs] on: Error do: [:ex | ex messageText = 'key not found' ifTrue: [^ nil]. ^ ex signal] ]. "args not checked against Renamed" ^ nil "was not in proper form"! ! !DisplayMedium methodsFor: 'displaying' stamp: 'hmm 9/16/2000 21:27'! deferUpdatesIn: aRectangle while: aBlock "DisplayScreen overrides with something more involved..." ^aBlock value! ! !DisplayScanner methodsFor: 'scanning' stamp: 'yo 10/7/2002 18:38'! displayLine: textLine offset: offset leftInRun: leftInRun "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | done stopCondition nowLeftInRun startIndex string lastPos | line _ textLine. morphicOffset _ offset. lineY _ line top + offset y. lineHeight _ line lineHeight. rightMargin _ line rightMargin + offset x. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. destX _ runX _ leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. destY _ lineY + line baseline - font ascent. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. string _ text string. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition. lastIndex > runStopIndex ifTrue: [done _ true]. ]. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !DisplayScanner methodsFor: 'scanning' stamp: 'ar 12/17/2001 13:28'! placeEmbeddedObject: anchoredMorph anchoredMorph relativeTextAnchorPosition ifNotNil:[ anchoredMorph position: anchoredMorph relativeTextAnchorPosition + (anchoredMorph owner textBounds origin x @ 0) - (0@morphicOffset y) + (0@lineY). ^true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [ anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset ] ifFalse: [ destY _ lineY. runX _ destX. anchoredMorph displayOn: bitBlt destForm at: destX - anchoredMorph width @ destY clippingBox: bitBlt clipRect ]. ^ true! ! !DisplayScanner methodsFor: 'private' stamp: 'hmm 9/16/2000 21:29'! setPort: aBitBlt "Install the BitBlt to use" bitBlt _ aBitBlt. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt sourceForm: nil. "Make sure font installation won't be confused" ! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'! plainTab | oldX | oldX _ destX. super plainTab. fillBlt == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'yo 10/4/2002 20:43'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). " alignment = Justified ifTrue: [ stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace] "! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'hmm 7/16/2000 08:23'! tab self plainTab. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'BG 5/31/2003 16:08'! displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle "The central display routine. The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated)." | runLength done stopCondition leftInRun startIndex string lastPos | "leftInRun is the # of characters left to scan in the current run; when 0, it is time to call 'self setStopConditions'" morphicOffset _ 0@0. leftInRun _ 0. self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. ignoreColorChanges _ false. paragraph _ aParagraph. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ bitBlt copy. "Blt to fill spaces, tabs, margins" fillBlt sourceForm: nil; sourceOrigin: 0@0. fillBlt fillColor: aParagraph backgroundColor]. rightMargin _ aParagraph rightMarginForDisplay. lineY _ aParagraph topAtLineIndex: linesInterval first. bitBlt destForm deferUpdatesIn: visibleRectangle while: [ linesInterval do: [:lineIndex | line _ aParagraph lines at: lineIndex. lastIndex _ line first. self setStopConditions. " causes an assignment to inst var. alignment " leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]). destX _ (runX _ leftMargin). line _ aParagraph lines at: lineIndex. lineHeight _ line lineHeight. fillBlt == nil ifFalse: [fillBlt destX: visibleRectangle left destY: lineY width: visibleRectangle width height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" leftInRun _ text runLengthFor: line first]. destY _ lineY + line baseline - font ascent. "Should have happened in setFont" runLength _ leftInRun. runStopIndex _ lastIndex + (runLength - 1) min: line last. leftInRun _ leftInRun - (runStopIndex - lastIndex + 1). spaceCount _ 0. done _ false. string _ text string. self handleIndentation. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fillBlt == nil ifFalse: [fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits]. lineY _ lineY + lineHeight]]! ! !DisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 3/14/2005 06:48'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle super initializeFromParagraph: aParagraph clippedBy: clippingRectangle. bitBlt _ BitBlt asGrafPort toForm: aParagraph destinationForm. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt combinationRule: ((Display depth = 1) ifTrue: [aParagraph rule] ifFalse: [Form paint]). bitBlt colorMap: (Bitmap with: 0 "Assumes 1-bit deep fonts" with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)). bitBlt clipRect: clippingRectangle! ! !DisplayScanner commentStamp: '' prior: 0! My instances are used to scan text and display it on the screen or in a hidden form.! !DisplayScreen methodsFor: 'displaying' stamp: 'ar 4/19/2001 05:44'! addExtraRegion: aRectangle for: regionDrawer "Register the given rectangle as a region which is drawn by the specified region drawer. The region will be excluded from any updates when #forceDamageToScreen: is called. Note that the rectangle is only valid for a single update cycle; once #forceDamageToScreen: has been called, the region drawer and its region are being removed from the list" extraRegions ifNil:[extraRegions _ #()]. extraRegions _ extraRegions copyWith: (Array with: regionDrawer with: aRectangle). ! ! !DisplayScreen methodsFor: 'displaying' stamp: 'sw 1/1/2005 01:31'! flashAll: rectangleList andWait: msecs "Flash the areas of the screen defined by the given rectangles." rectangleList do: [:aRectangle | self reverse: aRectangle]. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. rectangleList do: [:aRectangle | self reverse: aRectangle]. self forceDisplayUpdate. (Delay forMilliseconds: msecs) wait. ! ! !DisplayScreen methodsFor: 'displaying' stamp: 'ar 5/15/2001 20:08'! forceDamageToScreen: allDamage "Force all the damage rects to the screen." | rectList excluded remaining regions | rectList _ allDamage. "Note: Reset extra regions at the beginning to prevent repeated errors" regions _ extraRegions. extraRegions _ nil. regions ifNotNil:[ "exclude extra regions" regions do:[:drawerAndRect| excluded _ drawerAndRect at: 2. remaining _ WriteStream on: #(). rectList do:[:r| remaining nextPutAll:(r areasOutside: excluded)]. rectList _ remaining contents]. ]. rectList do:[:r| self forceToScreen: r]. regions ifNotNil:[ "Have the drawers paint what is needed" regions do:[:drawerAndRect| (drawerAndRect at: 1) forceToScreen]. ].! ! !DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:16'! deferUpdates: aBoolean | wasDeferred | "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer whether updates were deferred before if the primitive succeeds, nil if it fails." wasDeferred _ DeferringUpdates == true. DeferringUpdates _ aBoolean. ^(self primitiveDeferUpdates: aBoolean) ifNotNil: [wasDeferred]! ! !DisplayScreen methodsFor: 'other' stamp: 'hmm 2/2/2001 10:14'! deferUpdatesIn: aRectangle while: aBlock | result | (self deferUpdates: true) ifTrue: [^aBlock value]. result _ aBlock value. self deferUpdates: false. self forceToScreen: aRectangle. ^result! ! !DisplayScreen methodsFor: 'other' stamp: 'sd 6/7/2003 19:46'! fullScreenMode: aBoolean "On platforms that support it, set full-screen mode to the value of the argument. (Note: you'll need to restore the Display after calling this primitive." "Display fullScreenMode: true. Display newDepth: Display depth" self primitiveFailed ! ! !DisplayScreen methodsFor: 'other' stamp: 'hmm 6/18/2000 19:14'! primitiveDeferUpdates: aBoolean "Set the deferUpdates flag in the virtual machine. When this flag is true, BitBlt operations on the Display are not automatically propagated to the screen. If this underlying platform does not support deferred updates, this primitive will fail. Answer the receiver if the primitive succeeds, nil if it fails." ^ nil "answer nil if primitive fails" ! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 3/17/2001 23:53'! restore Smalltalk isMorphic ifTrue: [World fullRepaintNeeded] ifFalse: [ScheduledControllers unCacheWindows; restore].! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 3/17/2001 23:53'! restoreAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." aBlock value. Sensor waitButton. Smalltalk isMorphic ifTrue: [World fullRepaintNeeded] ifFalse: [(ScheduledControllers restore; activeController) view emphasize]! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/17/2001 21:02'! supportedDisplayDepths "Return all pixel depths supported on the current host platform." ^#(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) select: [:d | self supportsDisplayDepth: d]! ! !DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 21:03'! findAnyDisplayDepthIfNone: aBlock "Return any display depth that is supported on this system. If there is none, evaluate aBlock." #(1 2 4 8 16 32 -1 -2 -4 -8 -16 -32) do:[:bpp| (self supportsDisplayDepth: bpp) ifTrue:[^bpp]. ]. ^aBlock value! ! !DisplayScreen methodsFor: 'private' stamp: 'ar 5/17/2001 15:44'! newDepthNoRestore: pixelSize "Change depths. Check if there is enough space!! , di" | area need | pixelSize = depth ifTrue: [^ self "no change"]. pixelSize abs < self depth ifFalse: ["Make sure there is enough space" area _ Display boundingBox area. "pixels" Smalltalk isMorphic ifFalse: [ScheduledControllers scheduledWindowControllers do: [:aController | "This should be refined..." aController view cacheBitsAsTwoTone ifFalse: [area _ area + aController view windowBox area]]]. need _ (area * (pixelSize abs - self depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. self setExtent: self extent depth: pixelSize. Smalltalk isMorphic ifFalse: [ScheduledControllers updateGray]. DisplayScreen startUp! ! !DisplayScreen class methodsFor: 'display box access' stamp: 'sw 10/31/2001 07:18'! checkForNewScreenSize "Check whether the screen size has changed and if so take appropriate actions" Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. Smalltalk isMorphic ifTrue: [World restoreMorphicDisplay. World repositionFlapsAfterScreenSizeChange] ifFalse: [ScheduledControllers restore; searchForActiveController]! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 2/5/2001 17:24'! actualScreenDepth ^ Display depth! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'! startUp "DisplayScreen startUp" Display setExtent: self actualScreenSize depth: Display nativeDepth. Display beDisplay! ! !DisplayText methodsFor: 'displaying' stamp: 'yo 6/23/2003 20:05'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "For TT font, rule 34 is used if possible." "Refer to the comment in DisplayObject|displayOn:at:clippingBox:rule:mask:." | form1 rule | form1 _ self form. rule _ (ruleInteger = Form over and: [backColor isTransparent]) ifTrue: [form1 depth = 32 ifTrue: [rule _ 34] ifFalse: [Form paint]] ifFalse: [ruleInteger]. form1 depth = 32 ifTrue: [rule _ 34]. form1 displayOn: aDisplayMedium at: aDisplayPoint + offset clippingBox: clipRectangle rule: rule fillColor: aForm! ! !DisplayText methodsFor: 'private' stamp: 'nk 6/25/2003 12:51'! composeForm "For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery." | canvas tmpText | Smalltalk isMorphic ifTrue: [tmpText _ TextMorph new contentsAsIs: text deepCopy. foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)]. backColor ifNotNil: [tmpText backgroundColor: backColor]. tmpText setTextStyle: textStyle. canvas _ FormCanvas on: (Form extent: tmpText extent depth: 32). tmpText drawOn: canvas. form _ canvas form. ] ifFalse: [form _ self asParagraph asForm]! ! !DisplayText class methodsFor: 'examples' stamp: 'tk 11/28/2001 16:03'! example "Continually prints two lines of text wherever you point with the cursor. Terminate by pressing any button on the mouse." | tx | tx _ 'this is a line of characters and this is the second line.' asDisplayText. tx foregroundColor: Color black backgroundColor: Color transparent. tx _ tx alignedTo: #center. [Sensor anyButtonPressed] whileFalse: [tx displayOn: Display at: Sensor cursorPoint] "DisplayText example."! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates." ^self subclassResponsibility! ! !DoCommandOnceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color blue! ! !DoCommandOnceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 8! ! !DoCommandOnceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:08'! initialize "initialize the state of the receiver" super initialize. "" self useRoundedCorners! ! !DoItEvent methodsFor: 'testing' stamp: 'rw 7/14/2003 10:15'! isDoIt ^true! ! !DoItEvent methodsFor: 'printing' stamp: 'rw 7/14/2003 10:15'! printEventKindOn: aStream aStream nextPutAll: 'DoIt'! ! !DoItEvent methodsFor: 'accessing' stamp: 'rw 7/14/2003 11:29'! context ^context! ! !DoItEvent methodsFor: 'private-accessing' stamp: 'rw 7/14/2003 11:29'! context: aContext context := aContext! ! !DoItEvent class methodsFor: 'accessing' stamp: 'rw 7/14/2003 10:19'! changeKind ^#DoIt! ! !DoItEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:23'! supportedKinds ^ Array with: self expressionKind! ! !DoItEvent class methodsFor: 'instance creation' stamp: 'NS 1/19/2004 09:47'! expression: stringOrStream context: aContext | instance | instance := self item: stringOrStream kind: AbstractEvent expressionKind. instance context: aContext. ^instance! ! !DocLibrary methodsFor: 'doc pane' stamp: 'mir 11/14/2002 19:37'! docObjectAt: classAndMethod "Return a morphic object that is the documentation pane for this method. nil if none can be found. Look on both the network and the disk." | fileNames server aUrl strm local obj | methodVersions size = 0 ifTrue: [self updateMethodVersions]. "first time" fileNames _ self docNamesAt: classAndMethod. self assureCacheFolder. "server _ (ServerDirectory serverInGroupNamed: group) clone." "Note: directory ends with '/updates' which needs to be '/docpane', but altUrl end one level up" server _ ServerDirectory serverInGroupNamed: group. "later try multiple servers" aUrl _ server altUrl, 'docpane/'. fileNames do: [:aVersion | strm _ HTTPSocket httpGetNoError: aUrl,aVersion args: nil accept: 'application/octet-stream'. strm class == RWBinaryOrTextStream ifTrue: [ self cache: strm as: aVersion. strm reset. obj _ strm fileInObjectAndCode asMorph. (obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [ self inform: 'suspicious object'. obj setProperty: #classAndMethod toValue: classAndMethod]. ^ obj]. "The pasteUpMorph itself" "If file not there, error 404, just keep going"]. local _ ServerDirectory new fullPath: DocsCachePath. "check that it is really there -- let user respecify" fileNames do: [:aVersion | (local includesKey: aVersion) ifTrue: [ strm _ local readOnlyFileNamed: aVersion. obj _ strm fileInObjectAndCode asMorph. (obj valueOfProperty: #classAndMethod) = classAndMethod ifFalse: [ self inform: 'suspicious object'. obj setProperty: #classAndMethod toValue: classAndMethod]. Transcript cr; show: 'local cache: ', aVersion. ^ obj]. "The pasteUpMorph itself" "If file not there, just keep looking"]. "Never been documented" ^ nil! ! !DocLibrary methodsFor: 'doc pane' stamp: 'di 4/5/2001 21:38'! saveDocCheck: aMorph "Make sure the document gets attached to the version of the code that the user was looking at. Is there a version of this method in a changeSet beyond the updates we know about? Works even when the user has internal update numbers and the documentation is for external updates (It always is)." | classAndMethod parts selector class lastUp beyond ours docFor unNum ok key verList ext response | classAndMethod _ aMorph valueOfProperty: #classAndMethod. classAndMethod ifNil: [ ^ self error: 'need to know the class and method']. "later let user set it" parts _ classAndMethod findTokens: ' .'. selector _ parts last asSymbol. class _ Smalltalk at: (parts first asSymbol) ifAbsent: [^ self saveDoc: aMorph]. parts size = 3 ifTrue: [class _ class class]. "Four indexes we are looking for: docFor = highest numbered below lastUpdate that has method. unNum = a higher unnumbered set that has method. lastUp = lastUpdate we know about in methodVersions beyond = any set about lastUp that has the method." ChangeSorter allChangeSets doWithIndex: [:cs :ind | "youngest first" (cs name includesSubString: lastUpdateName) ifTrue: [lastUp _ ind]. (cs atSelector: selector class: class) ~~ #none ifTrue: [ lastUp ifNotNil: [beyond _ ind. ours _ cs name] ifNil: [cs name first isDigit ifTrue: [docFor _ ind] ifFalse: [unNum _ ind. ours _ cs name]]]]. "See if version the user sees is the version he is documenting" ok _ beyond == nil. unNum ifNotNil: [docFor ifNotNil: [ok _ docFor > unNum] ifNil: [ok _ false]]. "old changeSets gone" ok ifTrue: [^ self saveDoc: aMorph]. key _ DocLibrary properStemFor: classAndMethod. verList _ (methodVersions at: key ifAbsent: [#()]), #(0 0). ext _ verList first. "external update number we will write to" response _ (PopUpMenu labels: 'Cancel\Broadcast Page' withCRs) startUpWithCaption: 'You are documenting a method in External Update ', ext asString, '.\There is a more recent version of that method in ' withCRs, ours, '.\If you are explaining the newer version, please Cancel.\Wait until that version appears in an External Update.' withCRs. response = 2 ifTrue: [self saveDoc: aMorph]. ! ! !DocLibrary methodsFor: 'database of updates' stamp: 'mir 6/26/2001 12:07'! absorbAfter: oldVersion from: fileName "Read the .ix file and add to the methodVersions database. See class comment." | server aUrl strm newUpdate newName prevFile classAndMethod updateID key verList new | server _ ServerDirectory serverInGroupNamed: group. "later try multiple servers" aUrl _ server altUrl, 'docpane/', fileName. strm _ HTTPSocket httpGetNoError: aUrl args: nil accept: 'application/octet-stream'. strm class == RWBinaryOrTextStream ifFalse: [^ false]. (strm upTo: $ ) = 'External' ifFalse: [strm close. ^ false]. newUpdate _ Integer readFrom: strm. newUpdate = oldVersion ifTrue: [strm close. ^ false]. "already have it" strm upTo: $'. newName _ strm nextDelimited: $'. strm upTo: Character cr. prevFile _ strm upTo: Character cr. "does this report on updates just after what I know?" oldVersion = (prevFile splitInteger first) ifFalse: [ strm close. ^ prevFile]. "see earlier sucessor file" [strm atEnd] whileFalse: [ strm upTo: $'. classAndMethod _ strm nextDelimited: $'. strm next. updateID _ Integer readFrom: strm. key _ DocLibrary properStemFor: classAndMethod. verList _ methodVersions at: key ifAbsent: [#()]. (verList includes: updateID) ifFalse: [ new _ verList, (Array with: updateID with: -1 "file date seen"). methodVersions at: key put: new]]. strm close. lastUpdate _ newUpdate. lastUpdateName _ newName. ^ true! ! !DocLibrary methodsFor: 'database of updates' stamp: 'yo 7/16/2003 15:53'! updateMethodVersions "See if any new updates have occurred, and put their methods into the database." | indexFile list result | indexFile _ 'latest.ix'. list _ OrderedCollection new. [result _ self absorbAfter: lastUpdate from: indexFile. "boolean if succeeded, or we are up to date, or server not available" result isString] whileTrue: [ "result is the prev file name" list addFirst: indexFile. indexFile _ result]. list do: [:aFile | self absorbAfter: lastUpdate from: aFile]. "should always work this time" ! ! !DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:14'! driveName "return a possible drive letter and colon at the start of a Path name, empty string otherwise" | firstTwoChars | ( pathName asSqueakPathName size >= 2 ) ifTrue: [ firstTwoChars _ (pathName asSqueakPathName copyFrom: 1 to: 2). (self class isDrive: firstTwoChars) ifTrue: [^firstTwoChars] ]. ^''! ! !DosFileDirectory methodsFor: 'path access' stamp: 'nk 7/18/2004 17:26'! fullNameFor: fileName "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." fileName ifNil:[^fileName]. "Check for fully qualified names" ((fileName size >= 2 and: [fileName first isLetter and: [fileName second = $:]]) or: [(fileName beginsWith: '\\') and: [(fileName occurrencesOf: $\) >= 2]]) ifTrue:[^fileName]. ^super fullNameFor: fileName! ! !DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! fullPathFor: path "Return the fully-qualified path name for the given file." path isEmpty ifTrue:[^pathName asSqueakPathName]. (path at: 1) = $\ ifTrue:[ (path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^path]. "e.g., \\pipe\" ^self driveName , path "e.g., \windows\"]. (path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]]) ifTrue:[^path]. "e.g., c:" ^pathName asSqueakPathName, self slash, path! ! !DosFileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! relativeNameFor: path "Return the full name for path, assuming that path is a name relative to me." path isEmpty ifTrue:[^pathName asSqueakPathName]. (path at: 1) = $\ ifTrue:[ (path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^super relativeNameFor: path allButFirst ]. "e.g., \\pipe\" ^super relativeNameFor: path "e.g., \windows\"]. (path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]]) ifTrue:[^super relativeNameFor: (path copyFrom: 3 to: path size) ]. "e.g., c:" ^pathName asSqueakPathName, self slash, path! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 03:46'! isDrive: fullName "Answer whether the given full name describes a 'drive', e.g., one of the root directories of a Win32 file system. We allow two forms here - the classic one where a drive is specified by a letter followed by a colon, e.g., 'C:', 'D:' etc. and the network share form starting with double-backslashes e.g., '\\server'." ^ (fullName size = 2 and: [fullName first isLetter and: [fullName last = $:]]) or: [(fullName beginsWith: '\\') and: [(fullName occurrencesOf: $\) = 2]]! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 3/6/2004 04:14'! splitName: fullName to: pathAndNameBlock "Take the file name and convert it to the path name of a directory and a local file name within that directory. IMPORTANT NOTE: For 'drives', e.g., roots of the file system on Windows we treat the full name of that 'drive' as the local name rather than the path. This is because conceptually, all of these 'drives' hang off the virtual root of the entire Squeak file system, specified by FileDirectory root. In order to be consistent with, e.g., DosFileDirectory localNameFor: 'C:\Windows' -> 'Windows' DosFileDirectory dirPathFor: 'C:\Windows' -> 'C:' we expect the following to be true: DosFileDirectory localNameFor: 'C:' -> 'C:' DosFileDirectory dirPathFor: 'C:'. -> '' DosFileDirectory localNameFor: '\\server' -> '\\server'. DosFileDirectory dirPathFor: '\\server' -> ''. so that in turn the following relations hold: | fd | fd := DosFileDirectory on: 'C:\Windows'. fd containingDirectory includes: fd localName. fd := DosFileDirectory on: 'C:'. fd containingDirectory includes: fd localName. fd := DosFileDirectory on: '\\server'. fd containingDirectory includes: fd localName. " (self isDrive: fullName) ifTrue: [^ pathAndNameBlock value:'' value: fullName]. ^ super splitName: fullName to: pathAndNameBlock! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:03'! testFileDirectoryContainingDirectory "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory on: 'C:'. self assert: fd containingDirectory pathName = ''. ! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:05'! testFileDirectoryContainingDirectoryExistence "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory on: 'C:'. self assert: (fd containingDirectory fileOrDirectoryExists: 'C:').! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! testFileDirectoryContainingEntry "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory on: 'C:'. self assert: (fd containingDirectory entryAt: fd localName) notNil. ! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! testFileDirectoryDirectoryEntry "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory on: 'C:'. self assert: fd directoryEntry notNil.! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'! testFileDirectoryEntryFor "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory root directoryEntryFor: 'C:'. self assert: (fd name sameAs: 'C:').! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:21'! testFileDirectoryExists "Hoping that you have 'C:' of course..." FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. self assert: (FileDirectory root directoryExists: 'C:').! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:04'! testFileDirectoryLocalName "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory on: 'C:'. self assert: fd localName = 'C:'. ! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:19'! testFileDirectoryNamed "Hoping that you have 'C:' of course..." | fd | FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. fd := FileDirectory root directoryNamed: 'C:'. self assert: fd pathName = 'C:'.! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:14'! testFileDirectoryNonExistence "Hoping that you have 'C:' of course..." FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. self should: [(FileDirectory basicNew fileOrDirectoryExists: 'C:')] raise: InvalidDirectoryError.! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:13'! testFileDirectoryRootExistence "Hoping that you have 'C:' of course..." FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. self assert: (FileDirectory root fileOrDirectoryExists: 'C:').! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 4/27/2004 23:28'! testFullNameFor "Hoping that you have 'C:' of course..." FileDirectory activeDirectoryClass == DosFileDirectory ifFalse:[^self]. self assert: (FileDirectory default fullNameFor: 'C:') = 'C:'. self assert: (FileDirectory default fullNameFor: 'C:\test') = 'C:\test'. self assert: (FileDirectory default fullNameFor: '\\share') = '\\share'. self assert: (FileDirectory default fullNameFor: '\\share\test') = '\\share\test'. self assert: (FileDirectory default fullNameFor: '\test') = (FileDirectory default pathParts first, '\test'). ! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'! testIsDriveForDrive self assert: (DosFileDirectory isDrive: 'C:'). self deny: (DosFileDirectory isDrive: 'C:\'). self deny: (DosFileDirectory isDrive: 'C:\foo'). self deny: (DosFileDirectory isDrive: 'C:foo').! ! !DosFileDirectoryTests methodsFor: 'as yet unclassified' stamp: 'ar 3/6/2004 04:17'! testIsDriveForShare self assert: (DosFileDirectory isDrive: '\\server'). self deny: (DosFileDirectory isDrive: '\\server\'). self deny: (DosFileDirectory isDrive: '\\server\foo'). ! ! !DoubleClickExample methodsFor: 'accessing' stamp: 'nk 7/26/2004 10:38'! balloonText ^ 'Double-click on me to change my color; single-click on me to change border color; hold mouse down within me and then move it to grow (if I''m red) or shrink (if I''m blue).' translated ! ! !DoubleClickExample methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:22'! defaultColor "answer the default color/fill style for the receiver" ^ Color red! ! !DoubleClickExample class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:46'! descriptionForPartsBin ^ self partName: 'DoubleClick' categories: #('Demo') documentation: 'An example of how to use double-click in moprhic'! ! !DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:35'! drawOn: aCanvas aCanvas drawString: contents in: (bounds insetBy: 2) font: self fontToUse color: color. border ifNotNil: [aCanvas frameAndFillRectangle: bounds fillColor: Color transparent borderWidth: 1 borderColor: Color black]. aCanvas paintImage: SubMenuMarker at: (self right - 8 @ ((self top + self bottom - SubMenuMarker height) // 2))! ! !DropDownChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:51'! maxExtent: listOfStrings | h w maxW f | maxW _ 0. listOfStrings do: [:str | f _ self fontToUse. w _ f widthOfString: str. h _ f height. maxW _ maxW max: w]. self extent: (maxW + 4 + h) @ (h + 4). self changed! ! !DualChangeSorter methodsFor: 'initialization' stamp: 'sd 5/23/2003 14:38'! morphicWindow | window | leftCngSorter _ ChangeSorter new myChangeSet: ChangeSet current. leftCngSorter parent: self. rightCngSorter _ ChangeSorter new myChangeSet: ChangeSorter secondaryChangeSet. rightCngSorter parent: self. window _ (SystemWindow labelled: leftCngSorter label) model: self. "topView minimumSize: 300 @ 200." leftCngSorter openAsMorphIn: window rect: (0@0 extent: 0.5@1). rightCngSorter openAsMorphIn: window rect: (0.5@0 extent: 0.5@1). ^ window ! ! !DualChangeSorter methodsFor: 'initialization' stamp: 'sd 5/23/2003 14:38'! open | topView | Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph]. leftCngSorter _ ChangeSorter new myChangeSet: ChangeSet current. leftCngSorter parent: self. rightCngSorter _ ChangeSorter new myChangeSet: ChangeSorter secondaryChangeSet. rightCngSorter parent: self. topView _ (StandardSystemView new) model: self; borderWidth: 1. topView label: leftCngSorter label. topView minimumSize: 300 @ 200. leftCngSorter openView: topView offsetBy: 0@0. rightCngSorter openView: topView offsetBy: 360@0. topView controller open. ! ! !DualChangeSorter methodsFor: 'other' stamp: 'sd 5/23/2003 14:38'! labelString "The window label" | leftName rightName changesName | leftName _ leftCngSorter changeSetCategory categoryName. rightName _ rightCngSorter changeSetCategory categoryName. changesName _ 'Changes go to "', ChangeSet current name, '"'. ^ ((leftName ~~ #All) or: [rightName ~~ #All]) ifTrue: ['(', leftName, ') - ', changesName, ' - (', rightName, ')'] ifFalse: [changesName]! ! !DualChangeSorter class methodsFor: 'opening' stamp: 'sw 6/11/2001 17:38'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" ^ self new morphicWindow applyModelExtent! ! !DualChangeSorter class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:12'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Dual Change Sorter' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'Lets you view and manipulate two change sets concurrently.'! ! !DualChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:44'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(DualChangeSorter prototypicalToolWindow 'Change Sorter' 'Shows two change sets side by side') forFlapNamed: 'Tools']! ! !DualChangeSorter class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !DummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:48'! callingAnotherMethod! ! !DummyClassForTest methodsFor: 'as yet unclassified' stamp: 'sd 4/15/2003 20:48'! zoulouSymbol self callingAnotherMethod! ! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 20:48'! randomBitsFromSoundInput: bitCount "I'm not sure what the right thing to do here is." self error: 'Can not provide random data.'! ! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:54'! sampledSoundChoices "No choices other than this." ^ #('silence')! ! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:55'! soundNamed: soundName "There are no sounds to look up." ^ nil! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:53'! beep "Make a primitive beep." Beeper beepPrimitive! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:53'! playSampledSound: samples rate: rate "Do nothing." ! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! playSoundNamed: soundName "Do nothing."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName "Do nothing."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'nk 7/30/2004 17:52'! playSoundNamedOrBeep: soundName "There is no sound support, so we make the beep." ^Beeper beep! ! !DummySoundSystem commentStamp: 'gk 2/24/2004 23:14' prior: 0! This is a dummy sound system registered in SoundService to absorb all sound playing and to use the primitive beep instead of sampled sounds when playing a beep.! !DummySoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! initialize SoundService register: self new.! ! !DummySoundSystem class methodsFor: 'class initialization' stamp: 'gk 2/23/2004 21:08'! unload SoundService registeredClasses do: [:ss | (ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! ! !DummyToolWorkingWithFileList commentStamp: '' prior: 0! I'm a dummy class for testing that the registration of the tool to the FileList of actually happens. In the future the tests should cover that the class register when loaded in memory and unregister when unloaded.! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/6/2002 21:29'! fileReaderServicesForFile: fullName suffix: suffix ^ (suffix = 'kkk') ifTrue: [ self services] ifFalse: [#()] ! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/6/2002 21:46'! initialize "self initialize" FileList registerFileReader: self ! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/14/2001 22:12'! loadAFileForTheDummyTool: aFileListOrAPath "attention. if the file list selects a file the argument will be a fullpath of the selected file else it will pass the filelist itself"! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sw 2/17/2002 02:36'! serviceLoadAFilForDummyTool "Answer a service for opening the Dummy tool" ^ SimpleServiceEntry provider: self label: 'menu label' selector: #loadAFileForTheDummyTool: description: 'Menu label for dummy tool' buttonLabel: 'test'! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'sd 2/1/2002 22:32'! services ^ Array with: self serviceLoadAFilForDummyTool ! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !DummyToolWorkingWithFileList class methodsFor: 'class initialization' stamp: 'SD 11/10/2001 21:49'! unregister FileList unregisterFileReader: self. ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! * operand "operand is a Number" ^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger). ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! + operand "operand is a Duration" ^ self class nanoSeconds: (self asNanoSeconds + operand asNanoSeconds) ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:59'! - operand "operand is a Duration" ^ self + operand negated ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:00'! / operand "operand is a Duration or a Number" ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds / operand) asInteger ] ifFalse: [ self asNanoSeconds / operand asDuration asNanoSeconds ] . ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:00'! < comparand ^ self asNanoSeconds < comparand asNanoSeconds ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 1/9/2004 06:25'! = comparand "Answer whether the argument is a representing the same period of time as the receiver." ^ self == comparand ifTrue: [true] ifFalse: [self species = comparand species ifTrue: [self asNanoSeconds = comparand asNanoSeconds] ifFalse: [false] ]! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! abs ^ self class seconds: seconds abs nanoSeconds: nanos abs ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! asDuration ^ self ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! asSeconds ^ seconds ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 1/7/2004 16:20'! days "Answer the number of days the receiver represents." ^ seconds quo: SecondsInDay ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! hash ^seconds bitXor: nanos ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! hours "Answer the number of hours the receiver represents." ^ (seconds rem: SecondsInDay) quo: SecondsInHour ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:01'! minutes "Answer the number of minutes the receiver represents." ^ (seconds rem: SecondsInHour) quo: SecondsInMinute ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! negated ^ self class seconds: seconds negated nanoSeconds: nanos negated ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! negative ^ self positive not ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 08:02'! positive ^ seconds = 0 ifTrue: [ nanos positive ] ifFalse: [ seconds positive ] ! ! !Duration methodsFor: 'ansi protocol' stamp: 'brp 8/23/2003 10:03'! seconds "Answer the number of seconds the receiver represents." ^ (seconds rem: SecondsInMinute) + (nanos / NanosInSecond)! ! !Duration methodsFor: 'initialize-release' stamp: 'nk 3/30/2004 10:01'! initialize self seconds: 0 nanoSeconds: 0. ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 14:29'! // operand "operand is a Duration or a Number" ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds // operand) asInteger ] ifFalse: [ self asNanoSeconds // operand asDuration asNanoSeconds ] ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:07'! \\ operand "modulo. Remainder defined in terms of //. Answer a Duration with the same sign as aDuration. operand is a Duration or a Number." ^ operand isNumber ifTrue: [ self class nanoSeconds: (self asNanoSeconds \\ operand) ] ifFalse: [ self - (operand * (self // operand)) ] ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:42'! asDelay ^ Delay forDuration: self! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! asMilliSeconds ^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6) ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! asNanoSeconds ^ (seconds * NanosInSecond) + nanos ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 08:03'! nanoSeconds ^ nanos ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 13:22'! printOn: aStream "Format as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S]" | d h m s n | d _ self days abs. h _ self hours abs. m _ self minutes abs. s _ self seconds abs truncated. n _ self nanoSeconds abs. self negative ifTrue: [ aStream nextPut: $- ]. d printOn: aStream. aStream nextPut: $:. h < 10 ifTrue: [ aStream nextPut: $0. ]. h printOn: aStream. aStream nextPut: $:. m < 10 ifTrue: [ aStream nextPut: $0. ]. m printOn: aStream. aStream nextPut: $:. s < 10 ifTrue: [ aStream nextPut: $0. ]. s printOn: aStream. n = 0 ifFalse: [ | z ps | aStream nextPut: $.. ps _ n printString padded: #left to: 9 with: $0. z _ ps findLast: [ :c | c asciiValue > $0 asciiValue ]. ps from: 1 to: z do: [ :c | aStream nextPut: c ] ]. ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:42'! roundTo: aDuration "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 6 minutes." ^ self class nanoSeconds: (self asNanoSeconds roundTo: aDuration asNanoSeconds) ! ! !Duration methodsFor: 'squeak protocol' stamp: 'brp 9/25/2003 15:38'! truncateTo: aDuration "e.g. if the receiver is 5 minutes, 37 seconds, and aDuration is 2 minutes, answer 4 minutes." ^ self class nanoSeconds: (self asNanoSeconds truncateTo: aDuration asNanoSeconds) ! ! !Duration methodsFor: 'private' stamp: 'brp 7/27/2003 15:08'! seconds: secondCount nanoSeconds: nanoCount "Private - only used by Duration class" seconds _ secondCount. nanos _ nanoCount! ! !Duration methodsFor: 'private' stamp: 'brp 9/25/2003 14:42'! storeOn: aStream aStream nextPut: $(; nextPutAll: self className; nextPutAll: ' seconds: '; print: seconds; nextPutAll: ' nanoSeconds: '; print: nanos; nextPut: $). ! ! !Duration methodsFor: 'private' stamp: 'brp 8/23/2003 20:31'! ticks "Answer an array {days. seconds. nanoSeconds}. Used by DateAndTime and Time" ^ Array with: self days with: (self hours * 3600) + (self minutes * 60 ) + (self seconds truncated) with: self nanoSeconds! ! !Duration commentStamp: '' prior: 0! I represent a duration of time. I have nanosecond precision ! !Duration class methodsFor: 'ansi protocol' stamp: 'brp 5/13/2003 07:55'! days: days hours: hours minutes: minutes seconds: seconds ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: 0.! ! !Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:05'! seconds: aNumber ^ (self basicNew) seconds: aNumber nanoSeconds: 0; yourself. ! ! !Duration class methodsFor: 'ansi protocol' stamp: 'nk 3/30/2004 10:06'! zero ^ (self basicNew) seconds: 0 nanoSeconds: 0; yourself. ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:00'! days: aNumber ^ self days: aNumber hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 1/7/2004 15:38'! days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos ^ self nanoSeconds: ( ( (days * SecondsInDay) + (hours * SecondsInHour) + (minutes * SecondsInMinute) + seconds ) * NanosInSecond ) + nanos. ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 5/16/2003 11:29'! fromString: aString ^ self readFrom: (ReadStream on: aString) ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:00'! hours: aNumber ^ self days: 0 hours: aNumber minutes: 0 seconds: 0 nanoSeconds: 0! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:04'! milliSeconds: milliCount ^ self days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: (milliCount * (10 raisedToInteger: 6)) ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:01'! minutes: aNumber ^ self days: 0 hours: 0 minutes: aNumber seconds: 0 nanoSeconds: 0! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 1/9/2004 17:20'! month: aMonth "aMonth is an Integer or a String" ^ (Month month: aMonth year: Year current year) duration ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 5/21/2003 08:27'! nanoSeconds: nanos ^ self new seconds: (nanos quo: NanosInSecond) nanoSeconds: (nanos rem: NanosInSecond) rounded; yourself. ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 8/23/2003 12:47'! readFrom: aStream "Formatted as per ANSI 5.8.2.16: [-]D:HH:MM:SS[.S] To assiste DateAndTime>>#readFrom: SS may be unpadded or absent." | sign days hours minutes seconds nanos ws ch | sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. days _ (aStream upTo: $:) asInteger sign: sign. hours _ (aStream upTo: $:) asInteger sign: sign. minutes _ (aStream upTo: $:) asInteger sign: sign. aStream atEnd ifTrue: [seconds _ 0. nanos _ 0] ifFalse: [ ws _ String new writeStream. [ch _ aStream next. (ch isNil) | (ch = $.)] whileFalse: [ ws nextPut: ch ]. seconds _ ws contents asInteger sign: sign. ws reset. 9 timesRepeat: [ ch _ aStream next. ws nextPut: (ch ifNil: [$0] ifNotNil: [ch]) ]. nanos _ ws contents asInteger sign: sign]. ^ self days: days hours: hours minutes: minutes seconds: seconds nanoSeconds: nanos. " '0:00:00:00' asDuration '0:00:00:00.000000001' asDuration '0:00:00:00.999999999' asDuration '0:00:00:00.100000000' asDuration '0:00:00:00.10' asDuration '0:00:00:00.1' asDuration '0:00:00:01' asDuration '0:12:45:45' asDuration '1:00:00:00' asDuration '365:00:00:00' asDuration '-7:09:12:06.10' asDuration '+0:01:02' asDuration '+0:01:02:3' asDuration " ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 15:01'! seconds: seconds nanoSeconds: nanos ^ self days: 0 hours: 0 minutes: 0 seconds: seconds nanoSeconds: nanos ! ! !Duration class methodsFor: 'squeak protocol' stamp: 'brp 8/6/2003 18:54'! weeks: aNumber ^ self days: (aNumber * 7) hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0 ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:32'! testComparing | d1 d2 d3 | d1 _ Duration seconds: 10 nanoSeconds: 1. d2 _ Duration seconds: 10 nanoSeconds: 1. d3 _ Duration seconds: 10 nanoSeconds: 2. self assert: (d1 = d1); assert: (d1 = d2); deny: (d1 = d3); assert: (d1 < d3) ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:36'! testModulo | d1 d2 d3 | d1 _ 11.5 seconds. d2 _ d1 \\ 3. self assert: d2 = (Duration nanoSeconds: 1). d3 _ d1 \\ (3 seconds). self assert: d3 = (Duration seconds: 2 nanoSeconds: 500000000). self assert: aDuration \\ aDuration = (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: aDuration \\ 2 = (Duration days: 0 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 1). ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/16/2004 14:17'! testMonthDurations | jan feb dec | jan _ Duration month: #January. feb _ Duration month: #February. dec _ Duration month: #December. self assert: jan = (Year current months first duration); assert: feb = (Year current months second duration); assert: dec = (Year current months last duration) ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/9/2004 06:28'! testNumberConvenienceMethods self assert: 1 week = (Duration days: 7); assert: -1 week = (Duration days: -7); assert: 1 day = (Duration days: 1); assert: -1 day = (Duration days: -1); assert: 1 hours = (Duration hours: 1); assert: -1 hour = (Duration hours: -1); assert: 1 minute = (Duration seconds: 60); assert: -1 minute = (Duration seconds: -60); assert: 1 second = (Duration seconds: 1); assert: -1 second = (Duration seconds: -1); assert: 1 milliSecond = (Duration milliSeconds: 1); assert: -1 milliSecond = (Duration milliSeconds: -1); assert: 1 nanoSecond = (Duration nanoSeconds: 1); assert: -1 nanoSecond = (Duration nanoSeconds: -1) ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 9/25/2003 14:57'! testQuotient | d1 d2 q | d1 _ 11.5 seconds. d2 _ d1 // 3. self assert: d2 = (Duration seconds: 3 nanoSeconds: 833333333). q _ d1 // (3 seconds). self assert: q = 3. ! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:38'! testRoundTo self assert: ((5 minutes + 37 seconds) roundTo: (2 minutes)) = (6 minutes). self assert: (aDuration roundTo: (Duration days: 1)) = (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration roundTo: (Duration hours: 1)) = (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration roundTo: (Duration minutes: 1)) = (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! !DurationTest methodsFor: 'Tests' stamp: 'brp 1/21/2004 18:37'! testTruncateTo self assert: ((5 minutes + 37 seconds) truncateTo: (2 minutes)) = (4 minutes). self assert: (aDuration truncateTo: (Duration days: 1)) = (Duration days: 1 hours: 0 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration truncateTo: (Duration hours: 1)) = (Duration days: 1 hours: 2 minutes: 0 seconds: 0 nanoSeconds: 0). self assert: (aDuration truncateTo: (Duration minutes: 1)) = (Duration days: 1 hours: 2 minutes: 3 seconds: 0 nanoSeconds: 0).! ! !DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'! classToBeTested ^ Duration ! ! !DurationTest methodsFor: 'Coverage' stamp: 'brp 9/25/2003 14:30'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DurationTest methodsFor: 'running' stamp: 'brp 1/21/2004 18:36'! setUp aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAbs self assert: aDuration abs = aDuration. self assert: (Duration nanoSeconds: -5) abs = (Duration nanoSeconds: 5). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsDelay self deny: aDuration asDelay = aDuration. "want to come up with a more meaningful test" ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsDuration self assert: aDuration asDuration = aDuration ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsMilliSeconds self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: (Duration seconds: 1) asMilliSeconds = 1000. self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: (Duration nanoSeconds: 1000000) asMilliSeconds = 1. self assert: aDuration asMilliSeconds = 93784000.! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsNanoSeconds self assert: (Duration nanoSeconds: 1) asNanoSeconds = 1. self assert: (Duration seconds: 1) asNanoSeconds = 1000000000. self assert: aDuration asNanoSeconds = 93784000000005.! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsSeconds self assert: (Duration nanoSeconds: 1000000000) asSeconds = 1. self assert: (Duration seconds: 1) asSeconds = 1. self assert: aDuration asSeconds = 93784.! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testDays self assert: aDuration days = 1. self assert: (Duration days: 1) days= 1. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testDivide self assert: aDuration / aDuration = 1. self assert: aDuration / 2 = (Duration days: 0 hours: 13 minutes: 1 seconds: 32 nanoSeconds: 2). self assert: aDuration / (1/2) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testFromString self assert: aDuration = (Duration fromString: '1:02:03:04.000000005'). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testHash self assert: aDuration hash = (Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5) hash. self assert: aDuration hash = 93789 "must be a more meaningful test?"! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testHours self assert: aDuration hours = 2. self assert: (Duration hours: 2) hours = 2. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testIntegerDivision self assert: aDuration // aDuration = 1. self assert: aDuration // 2 = (aDuration / 2). "is there ever a case where this is not true, since precision is always to the nano second?"! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testLessThan self assert: aDuration < (aDuration + 1 day ). self deny: aDuration < aDuration. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testMilliSeconds self assert: (Duration milliSeconds: 5) nanoSeconds = 5000000. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testMinus self assert: aDuration - aDuration = (Duration seconds: 0). self assert: aDuration - (Duration days: -1 hours: -2 minutes: -3 seconds: -4 nanoSeconds: -5) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). self assert: aDuration - (Duration days: 0 hours: 1 minutes: 2 seconds: 3 nanoSeconds: 4) = (Duration days: 1 hours: 1 minutes: 1 seconds: 1 nanoSeconds: 1). self assert: aDuration - (Duration days: 0 hours: 3 minutes: 0 seconds: 5 nanoSeconds: 0) = (Duration days: 0 hours: 23 minutes: 2 seconds: 59 nanoSeconds: 5). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testMinutes self assert: aDuration minutes = 3. self assert: (Duration minutes: 3) minutes = 3. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testMultiply self assert: aDuration * 2 = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNanoSeconds self assert: aDuration nanoSeconds = 5. self assert: (Duration nanoSeconds: 5) nanoSeconds = 5. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNegated self assert: aDuration + aDuration negated = (Duration seconds: 0). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNegative self deny: aDuration negative. self assert: aDuration negated negative ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNew "self assert: Duration new = (Duration seconds: 0)." "new is not valid as a creation method: MessageNotUnderstood: UndefinedObject>>quo:, where Duration seconds is nil"! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testPlus self assert: (aDuration + 0 hours) = aDuration. self assert: (aDuration + aDuration) = (Duration days: 2 hours: 4 minutes: 6 seconds: 8 nanoSeconds: 10). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testPositive self assert: (Duration nanoSeconds: 0) positive. self assert: aDuration positive. self deny: aDuration negated positive ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testPrintOn |cs rw | cs _ ReadStream on: '1:02:03:04.000000005'. rw _ ReadWriteStream on: ''. aDuration printOn: rw. self assert: rw contents = cs contents.! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testReadFrom self assert: aDuration = (Duration readFrom: (ReadStream on: '1:02:03:04.000000005')) ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testSeconds self assert: aDuration seconds = (800000001/200000000). self assert: (Duration nanoSeconds: 2) seconds = (2/1000000000). self assert: (Duration seconds: 2) seconds = 2. self assert: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (4). self deny: (Duration days: 1 hours: 2 minutes: 3 seconds:4) seconds = (1*24*60*60+(2*60*60)+(3*60)+4). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testSecondsNanoSeconds self assert: (Duration seconds: 0 nanoSeconds: 5) = (Duration nanoSeconds: 5). "not sure I should include in sunit since its Private " self assert: (aDuration seconds: 0 nanoSeconds: 1) = (Duration nanoSeconds: 1). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testStoreOn self assert: (aDuration storeOn: (WriteStream on:'')) asString ='1:02:03:04.000000005'. "storeOn: returns a duration (self) not a stream"! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testTicks self assert: aDuration ticks = #(1 7384 5)! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testWeeks self assert: (Duration weeks: 1) days= 7. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testZero self assert: (Duration zero) = (Duration seconds: 0). ! ! !EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 12/28/2002 22:03'! readCharactersInRangeFrom: start to: stop totalNums: upToNum storeInto: chars | array form code | 1 to: upToNum do: [:i | array _ self readOneCharacter. code _ array at: 2. code > stop ifTrue: [^ self]. (code between: start and: stop) ifTrue: [ form _ array at: 1. form ifNotNil: [ chars add: array. ]. ]. ]. ! ! !EFontBDFFontReader methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 15:29'! readFrom: start to: end | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. (properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [ pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. ] ifFalse: [ pointSize _ (ascent + descent) * 72 // 96. ]. maxWidth _ 0. minAscii _ 16r200000. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. self readCharactersInRangeFrom: start to: end totalNums: charsNum storeInto: chars. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" chars do: [:array | encoding _ array at: 2. bbx _ array at: 3.. width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. ]. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. "xTable _ XTableForUnicodeFont new ranges: (Array with: (Array with: start with: end))." xTable _ SparseLargeTable new: end + 3 chunkSize: 32 arrayClass: Array base: start + 1 defaultValue: -1. lastAscii _ start. 1 to: charsNum do: [:i | form _ (chars at: i) first. encoding _ (chars at: i) second. bbx _ (chars at: i) third. "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." lastValue _ xTable at: lastAscii + 1 + 1. xTable at: encoding + 1 put: lastValue. blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). lastAscii _ encoding. ]. xTable zapDefaultOnlyEntries. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 11/30/2003 16:55'! additionalRangesForJapanese | basics | basics _ { Array with: 16r5C with: 16rFF3C. Array with: 16r3013 with: 16rFFFD. }. ^ basics ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 16:46'! additionalRangesForKorean | basics | basics _ { Array with: 16rA1 with: 16rFFE6C. Array with: 16r3000 with: 16rFFFD. }. ^ basics ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 5/26/2004 23:26'! override: chars with: otherFileName ranges: pairArray transcodingTable: table additionalRange: additionalRange | other rangeStream currentRange newChars code form u newArray j | other _ BDFFontReader readOnlyFileNamed: otherFileName. rangeStream _ ReadStream on: pairArray. currentRange _ rangeStream next. newChars _ PluggableSet new. newChars hashBlock: [:elem | (elem at: 2) hash]. newChars equalBlock: [:a :b | (a at: 2) = (b at: 2)]. other readChars do: [:array | code _ array at: 2. code hex printString displayAt: 0@0. code > currentRange last ifTrue: [ [rangeStream atEnd not and: [currentRange _ rangeStream next. currentRange last < code]] whileTrue. rangeStream atEnd ifTrue: [ newChars addAll: chars. ^ newChars. ]. ]. (code between: currentRange first and: currentRange last) ifTrue: [ form _ array at: 1. form ifNotNil: [ j _ array at: 2. u _ table at: (((j // 256) - 33 * 94 + ((j \\ 256) - 33)) + 1). u ~= -1 ifTrue: [ array at: 2 put: u. newChars add: array. additionalRange do: [:e | e first = (array at: 2) ifTrue: [ newArray _ array clone. newArray at: 2 put: e second. newChars add: newArray ]. ] ]. ]. ]. ]. self error: 'should not reach here'. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 2/14/2004 02:46'! rangesForGreek ^ { Array with: 16r1 with: 16rFF. Array with: 16r370 with: 16r3FF. Array with: 16r1F00 with: 16r1FFF. Array with: 16r2000 with: 16r206F. Array with: 16r20A0 with: 16r20AF }. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2004 23:12'! rangesForJapanese | basics etc | basics _ { Array with: 16r5C with: 16r5C. Array with: 16rA2 with: 16rA3. Array with: 16rA7 with: 16rA8. Array with: 16rAC with: 16rAC. Array with: 16rB0 with: 16rB1. Array with: 16rB4 with: 16rB4. Array with: 16rB6 with: 16rB6. Array with: 16rD7 with: 16rD7. Array with: 16rF7 with: 16rF7 }. etc _ { Array with: 16r370 with: 16r3FF. "greek" Array with: 16r400 with: 16r52F. "cyrillic" Array with: 16r1D00 with: 16r1D7F. "phonetic" Array with: 16r1E00 with: 16r1EFF. "latin extended additional" Array with: 16r2000 with: 16r206F. "general punctuation" Array with: 16r20A0 with: 16r20CF. "currency symbols" Array with: 16r2100 with: 16r214F. "letterlike" Array with: 16r2150 with: 16r218F. "number form" Array with: 16r2190 with: 16r21FF. "arrows" Array with: 16r2200 with: 16r22FF. "math operators" Array with: 16r2300 with: 16r23FF. "misc tech" Array with: 16r2460 with: 16r24FF. "enclosed alnum" Array with: 16r2500 with: 16r257F. "box drawing" Array with: 16r2580 with: 16r259F. "box elem" Array with: 16r25A0 with: 16r25FF. "geometric shapes" Array with: 16r2600 with: 16r26FF. "misc symbols" Array with: 16r2700 with: 16r27BF. "dingbats" Array with: 16r27C0 with: 16r27EF. "misc math A" Array with: 16r27F0 with: 16r27FF. "supplimental arrow A" Array with: 16r2900 with: 16r297F. "supplimental arrow B" Array with: 16r2980 with: 16r29FF. "misc math B" Array with: 16r2A00 with: 16r2AFF. "supplimental math op" Array with: 16r2900 with: 16r297F. "supplimental arrow B" Array with: 16r2E80 with: 16r2EFF. "cjk radicals suppliment" Array with: 16r2F00 with: 16r2FDF. "kangxi radicals" Array with: 16r3000 with: 16r303F. "cjk symbols" Array with: 16r3040 with: 16r309F. "hiragana" Array with: 16r30A0 with: 16r30FF. "katakana" Array with: 16r3190 with: 16r319F. "kanbun" Array with: 16r31F0 with: 16r31FF. "katakana extension" Array with: 16r3200 with: 16r32FF. "enclosed CJK" Array with: 16r3300 with: 16r33FF. "CJK compatibility" Array with: 16r3400 with: 16r4DBF. "CJK unified extension A" Array with: 16r4E00 with: 16r9FAF. "CJK ideograph" Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph" Array with: 16rFE30 with: 16rFE4F. "CJK compatiblity forms" Array with: 16rFF00 with: 16rFFEF. "half and full" Array with: 16rFFFF with: 16rFFFF. "sentinel" }. ^ basics, etc. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/15/2004 16:53'! rangesForKorean | basics etc | basics _ { Array with: 16rA1 with: 16rFF }. etc _ { Array with: 16r100 with: 16r17F. "extended latin" Array with: 16r370 with: 16r3FF. "greek" Array with: 16r400 with: 16r52F. "cyrillic" Array with: 16r2000 with: 16r206F. "general punctuation" Array with: 16r2100 with: 16r214F. "letterlike" Array with: 16r2150 with: 16r218F. "number form" Array with: 16r2190 with: 16r21FF. "arrows" Array with: 16r2200 with: 16r22FF. "math operators" Array with: 16r2300 with: 16r23FF. "misc tech" Array with: 16r2460 with: 16r24FF. "enclosed alnum" Array with: 16r2500 with: 16r257F. "box drawing" Array with: 16r2580 with: 16r259F. "box elem" Array with: 16r25A0 with: 16r25FF. "geometric shapes" Array with: 16r2600 with: 16r26FF. "misc symbols" Array with: 16r3000 with: 16r303F. "cjk symbols" Array with: 16r3040 with: 16r309F. "hiragana" Array with: 16r30A0 with: 16r30FF. "katakana" Array with: 16r3190 with: 16r319F. "kanbun" Array with: 16r31F0 with: 16r31FF. "katakana extension" Array with: 16r3200 with: 16r32FF. "enclosed CJK" Array with: 16r3300 with: 16r33FF. "CJK compatibility" Array with: 16r4E00 with: 16r9FAF. "CJK ideograph" Array with: 16rAC00 with: 16rD7AF. "Hangul Syllables" Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph" Array with: 16rFF00 with: 16rFFEF. "half and full" }. ^ basics, etc. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:20'! rangesForLatin2 ^ { Array with: 0 with: 16r17F. Array with: 16r2B0 with: 16r2FF. Array with: 16r2000 with: 16r206F. Array with: 16r2122 with: 16r2122. Array with: 16rFFFF with: 16rFFFF. "sentinel" }. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2004 23:20'! readCharactersInRanges: ranges storeInto: chars | array form code rangeStream currentRange | rangeStream _ ReadStream on: ranges. currentRange _ rangeStream next. [true] whileTrue: [ array _ self readOneCharacter. array second ifNil: [^ self]. code _ array at: 2. code > currentRange last ifTrue: [ [rangeStream atEnd not and: [currentRange _ rangeStream next. currentRange last < code]] whileTrue. rangeStream atEnd ifTrue: [^ self]. ]. (code between: currentRange first and: currentRange last) ifTrue: [ form _ array at: 1. form ifNotNil: [ chars add: array. ]. ]. ]. ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:26'! readRanges: ranges | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. (properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [ pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. ] ifFalse: [ pointSize _ (ascent + descent) * 72 // 96. ]. maxWidth _ 0. minAscii _ 16r200000. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. self readCharactersInRanges: ranges storeInto: chars. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" chars do: [:array | encoding _ array at: 2. bbx _ array at: 3.. width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. ]. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. start _ (ranges collect: [:r | r first]) min. end _ (ranges collect: [:r | r second]) max + 3. xTable _ SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start +1 defaultValue: -1. lastAscii _ start. xTable at: lastAscii + 2 put: 0. 1 to: charsNum do: [:i | form _ (chars at: i) first. encoding _ (chars at: i) second. bbx _ (chars at: i) third. "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." lastValue _ xTable at: lastAscii + 1 + 1. xTable at: encoding + 1 put: lastValue. blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). lastAscii _ encoding. ]. xTable at: xTable size put: (xTable at: xTable size - 1). xTable zapDefaultOnlyEntries. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" ! ! !EFontBDFFontReaderForRanges methodsFor: 'as yet unclassified' stamp: 'yo 5/26/2004 14:43'! readRanges: ranges overrideWith: otherFileName otherRanges: otherRanges additionalOverrideRange: additionalRange | xTable strikeWidth glyphs ascent descent minAscii maxAscii maxWidth chars charsNum height form encoding bbx width blt lastAscii pointSize ret lastValue start end | form _ encoding _ bbx _ nil. self initialize. self readAttributes. height _ Integer readFromString: ((properties at: #FONTBOUNDINGBOX) at: 2). ascent _ Integer readFromString: (properties at: 'FONT_ASCENT' asSymbol) first. descent _ Integer readFromString: (properties at: 'FONT_DESCENT' asSymbol) first. (properties includesKey: 'POINT_SIZE' asSymbol) ifTrue: [ pointSize _ (Integer readFromString: (properties at: 'POINT_SIZE' asSymbol) first) // 10. ] ifFalse: [ pointSize _ (ascent + descent) * 72 // 96. ]. maxWidth _ 0. minAscii _ 16r200000. strikeWidth _ 0. maxAscii _ 0. charsNum _ Integer readFromString: (properties at: #CHARS) first. chars _ Set new: charsNum. self readCharactersInRanges: ranges storeInto: chars. chars _ self override: chars with: otherFileName ranges: otherRanges transcodingTable: (UCSTable jisx0208Table) additionalRange: additionalRange. chars _ chars asSortedCollection: [:x :y | (x at: 2) <= (y at: 2)]. charsNum _ chars size. "undefined encodings make this different" chars do: [:array | encoding _ array at: 2. bbx _ array at: 3.. width _ bbx at: 1. maxWidth _ maxWidth max: width. minAscii _ minAscii min: encoding. maxAscii _ maxAscii max: encoding. strikeWidth _ strikeWidth + width. ]. glyphs _ Form extent: strikeWidth@height. blt _ BitBlt toForm: glyphs. start _ ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min. end _ ((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 3. "xRange _ Array with: (Array with: ((ranges collect: [:r | r first]), (additionalRange collect: [:r2 | r2 first])) min with: (((ranges collect: [:r | r second]), (additionalRange collect: [:r2 | r2 second])) max + 2))." "xTable _ XTableForUnicodeFont new ranges: xRange." xTable _ SparseLargeTable new: end chunkSize: 64 arrayClass: Array base: start defaultValue: -1. lastAscii _ start. xTable at: lastAscii + 2 put: 0. 1 to: charsNum do: [:i | form _ (chars at: i) first. encoding _ (chars at: i) second. bbx _ (chars at: i) third. "lastAscii+1 to: encoding-1 do: [:a | xTable at: a+2 put: (xTable at: a+1)]." lastValue _ xTable at: lastAscii + 1 + 1. xTable at: encoding + 1 put: lastValue. blt copy: (((xTable at: encoding+1)@(ascent - (bbx at: 2) - (bbx at: 4))) extent: (bbx at: 1)@(bbx at: 2)) from: 0@0 in: form. xTable at: encoding+2 put: (xTable at: encoding+1)+(bbx at: 1). lastAscii _ encoding. ]. xTable at: xTable size put: (xTable at: xTable size - 1). xTable zapDefaultOnlyEntries. ret _ Array new: 8. ret at: 1 put: xTable. ret at: 2 put: glyphs. ret at: 3 put: minAscii. ret at: 4 put: maxAscii. ret at: 5 put: maxWidth. ret at: 6 put: ascent. ret at: 7 put: descent. ret at: 8 put: pointSize. ^ret. " ^{xTable. glyphs. minAscii. maxAscii. maxWidth. ascent. descent. pointSize}" ! ! !EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'! rangesForGreek ^ { Array with: 16r1 with: 16rFF. Array with: 16r370 with: 16r3FF. Array with: 16r1F00 with: 16r1FFF. Array with: 16r2000 with: 16r206F. Array with: 16r20A0 with: 16r20AF }. ! ! !EFontBDFFontReaderForRanges class methodsFor: 'as yet unclassified' stamp: 'yo 1/19/2005 11:24'! rangesForLatin2 ^ { Array with: 0 with: 16r17F. Array with: 16r2B0 with: 16r2FF. Array with: 16r2000 with: 16r206F. Array with: 16r2122 with: 16r2122. Array with: 16rFFFF with: 16rFFFF. "sentinel" }. ! ! !EPSCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:53'! fullDraw: aMorph super fullDraw: aMorph. morphLevel = 0 ifTrue: [ self writeTrailer: 1. ]! ! !EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 18:29'! pageBBox ^psBounds! ! !EPSCanvas methodsFor: 'page geometry' stamp: 'nk 1/1/2004 20:22'! pageOffset ^0@0! ! !EPSCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 12:48'! writeEPSPreviewImageFor: aMorph | form stream string lines newExtent | newExtent _ (aMorph width roundUpTo: 8) @ aMorph height. form _ aMorph imageForm: 1 forRectangle: (aMorph bounds origin extent: newExtent). stream _ RWBinaryOrTextStream on: (String new: (form bits byteSize * 2.04) asInteger). form storePostscriptHexOn: stream. string _ stream contents. lines _ string occurrencesOf: Character cr. "%%BeginPreview: 80 24 1 24" "width height depth " target print: '%%BeginPreview: '; write: newExtent; space; write: form depth; space; write: lines; cr. stream position: 0. [ stream atEnd ] whileFalse: [ target nextPut: $%; nextPutAll: (stream upTo: Character cr); cr. lines _ lines - 1. ]. target print: '%%EndPreview'; cr. ! ! !EPSCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:31'! writePSIdentifierRotated: rotateFlag target print: '%!!PS-Adobe-2.0 EPSF-2.0'; cr. rotateFlag ifTrue: [target print: '%%BoundingBox: '; write: (0 @ 0 corner: psBounds corner transposed) rounded; cr] ifFalse: [target print: '%%BoundingBox: '; write: psBounds rounded; cr]. target print: '%%Title: '; print: self topLevelMorph externalName; cr. target print: '%%Creator: '; print: Utilities authorName; cr. target print: '%%CreationDate: '; print: Date today asString; space; print: Time now asString; cr. "is this relevant?" target print: '%%Orientation: '; print: (rotateFlag ifTrue: [ 'Landscape' ] ifFalse: [ 'Portrait' ]); cr. target print: '%%DocumentFonts: (atend)'; cr. target print: '%%EndComments'; cr " self writeEPSPreviewImageFor: topLevelMorph." " target print: '%%EndProlog'; cr."! ! !EPSCanvas class methodsFor: 'configuring' stamp: 'nk 1/1/2004 20:22'! baseOffset ^0@0.! ! !EPSCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'! defaultExtension ^'.eps'! ! !EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 12/17/2001 02:18'! chatFrom: ipAddress name: senderName text: text | initialText attrib | recipientForm ifNil: [ initialText _ senderName asText allBold. ] ifNotNil: [ attrib _ TextAnchor new anchoredMorph: recipientForm "asMorph". initialText _ (String value: 1) asText. initialText addAttribute: attrib from: 1 to: 1. ]. self appendMessage: initialText,' - ',text,String cr. EToyCommunicatorMorph playArrivalSound. ! ! !EToyChatMorph methodsFor: 'as yet unclassified' stamp: 'ar 12/17/2001 02:18'! startOfMessageFromMe myForm ifNil: [ myForm _ EToySenderMorph pictureForIPAddress: NetNameResolver localAddressString. myForm ifNotNil: [ myForm _ myForm scaledToSize: 20@20 ]. ]. myForm ifNil: [ ^(Preferences defaultAuthorName asText allBold addAttribute: TextColor blue) ]. ^(String value: 1) asText addAttribute: (TextAnchor new anchoredMorph: myForm); yourself ! ! !EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self standardBorderColor! ! !EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 8! ! !EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! defaultBounds "answer the default bounds for the receiver" ^ 400 @ 100 extent: 200 @ 150! ! !EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ! !EToyChatMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:36'! initialize "initialize the state of the receiver" super initialize. "" acceptOnCR _ true. self listDirection: #topToBottom; layoutInset: 0; hResizing: #shrinkWrap; vResizing: #shrinkWrap; rubberBandCells: false; minWidth: 200; minHeight: 200; rebuild ! ! !EToyChatMorph class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:50'! descriptionForPartsBin ^ self partName: 'Text chat' categories: #('Collaborative') documentation: 'A tool for sending messages to other Squeak uers'! ! !EToyCommunicatorMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:32'! initialize "initialize the state of the receiver" super initialize. "" self vResizing: #shrinkWrap; hResizing: #shrinkWrap. resultQueue _ SharedQueue new. fields _ Dictionary new. self useRoundedCorners! ! !EToyCommunicatorMorph class methodsFor: 'as yet unclassified' stamp: 'gk 2/23/2004 21:07'! playArrivalSound "Make a sound that something has arrived." SoundService default playSoundNamedOrBeep: 'chirp'! ! !EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'tk 7/25/2001 17:40'! rebuild | row filler fudge people maxPerRow insetY | updateCounter _ self class updateCounter. self removeAllMorphs. (self addARow: { filler _ Morph new color: Color transparent; extent: 4@4. }) vResizing: #shrinkWrap. self addARow: { (StringMorph contents: 'the Fridge') lock. self groupToggleButton. }. row _ self addARow: {}. people _ self class fridgeRecipients. maxPerRow _ people size < 7 ifTrue: [2] ifFalse: [3]. "how big can this get before we need a different approach?" people do: [ :each | row submorphCount >= maxPerRow ifTrue: [row _ self addARow: {}]. row addMorphBack: ( groupMode ifTrue: [ (each userPicture scaledToSize: 35@35) asMorph lock ] ifFalse: [ each veryDeepCopy killExistingChat ] ) ]. fullBounds _ nil. self fullBounds. "htsBefore _ submorphs collect: [ :each | each height]." fudge _ 20. insetY _ self layoutInset. insetY isPoint ifTrue: [insetY _ insetY y]. filler extent: 4 @ (self height - filler height * 0.37 - insetY - borderWidth - fudge) truncated. "self fixLayout. htsAfter _ submorphs collect: [ :each | each height]. {htsBefore. htsAfter} explore." ! ! !EToyFridgeMorph methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! trulyFlashIndicator: aSymbol | state | state _ (self valueOfProperty: #fridgeFlashingState ifAbsent: [false]) not. self setProperty: #fridgeFlashingState toValue: state. self addMouseActionIndicatorsWidth: 15 color: (Color green alpha: (state ifTrue: [0.3] ifFalse: [0.7])). Beeper beep. "self world displayWorldSafely."! ! !EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ #raised! ! !EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleRed! ! !EToyFridgeMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:58'! initialize "initialize the state of the receiver" super initialize. "" groupMode _ true. self listDirection: #topToBottom; layoutInset: 10; hResizing: #shrinkWrap; vResizing: #shrinkWrap; setProperty: #normalBorderColor toValue: self borderColor; setProperty: #flashingColors toValue: {Color red. Color yellow}; rebuild! ! !EToyFridgeMorph methodsFor: 'layout' stamp: 'RAA 3/7/2001 22:31'! acceptDroppingMorph: morphToDrop event: evt | outData | (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these" ^morphToDrop rejectDropMorphEvent: evt ]. self eToyRejectDropMorph: morphToDrop event: evt. "we will keep a copy" (morphToDrop isKindOf: EToySenderMorph) ifTrue: [ self class addRecipient: morphToDrop. ^self rebuild ]. self stopFlashing. "7 mar 2001 - remove #veryDeepCopy" outData _ morphToDrop eToyStreamedRepresentationNotifying: self. self resetIndicator: #working. self class fridgeRecipients do: [ :each | self transmitStreamedObject: outData to: each ipAddress ]. ! ! !EToyFridgeMorph class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:50'! descriptionForPartsBin ^ self partName: 'Fridge' categories: #('Collaborative') documentation: 'A tool for sending objects to other Squeak uers'! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 12:42'! acceptableTypes ^acceptableTypes! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:11'! dateAndTimeStringFrom: totalSeconds | dateAndTime | dateAndTime _ Time dateAndTimeFromSeconds: totalSeconds. ^dateAndTime first printString,' ',dateAndTime second printString! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:51'! fullInfoString ^self latestUserName, ' at ', ipAddress , ' attempts: ', accessAttempts printString, '/', attempsDenied printString, ' last: ', (self lastIncomingMessageTimeString) "acceptableTypes" ! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 12:19'! getChoice: aString ^acceptableTypes includes: aString! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:33'! ipAddress ^ipAddress! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:18'! ipAddress: aString ipAddress _ aString! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:37'! lastIncomingMessageTimeString lastRequests isEmpty ifTrue: [^'never']. ^self dateAndTimeStringFrom: lastRequests first first ! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:56'! lastTimeChecked ^self valueOfProperty: #lastTimeChecked ! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 13:57'! lastTimeChecked: aDateAndTimeInSeconds self setProperty: #lastTimeChecked toValue: aDateAndTimeInSeconds ! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:22'! lastTimeCheckedString | statusTime | statusTime _ self valueOfProperty: #lastTimeChecked ifAbsent: [^'none']. ^(self dateAndTimeStringFrom: statusTime)! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:49'! latestUserName ^latestUserName ifNil: ['???']! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:46'! latestUserName: aString latestUserName _ aString! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:09'! requestAccessOfType: aString | ok | accessAttempts _ accessAttempts + 1. lastRequests addFirst: {Time totalSeconds. aString}. lastRequests size > 10 ifTrue: [ lastRequests _ lastRequests copyFrom: 1 to: 10. ]. ok _ (acceptableTypes includes: aString) or: [acceptableTypes includes: 'all']. ok ifFalse: [attempsDenied _ attempsDenied + 1]. ^ok! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/31/2000 14:10'! statusReplyReceived: anArray self setProperty: #lastStatusReplyTime toValue: Time totalSeconds. self setProperty: #lastStatusReply toValue: anArray.! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 8/1/2000 14:16'! statusReplyReceivedString | statusTime | statusTime _ self valueOfProperty: #lastStatusReplyTime ifAbsent: [^'none']. ^(self dateAndTimeStringFrom: statusTime),' accepts: ', (self valueOfProperty: #lastStatusReply) asArray printString! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 09:38'! timeBetweenLastAccessAnd: currentTime lastRequests isEmpty ifTrue: [^0]. ^currentTime - lastRequests first first ! ! !EToyGateKeeperEntry methodsFor: 'as yet unclassified' stamp: 'RAA 7/11/2000 10:39'! toggleChoice: aString (acceptableTypes includes: aString) ifTrue: [ acceptableTypes remove: aString ifAbsent: [] ] ifFalse: [ acceptableTypes add: aString ].! ! !EToyGateKeeperEntry methodsFor: 'initialization' stamp: 'RAA 8/4/2000 11:49'! initialize self flag: #bob. "need to decide better initial types" super initialize. ipAddress _ '???'. accessAttempts _ attempsDenied _ 0. lastRequests _ OrderedCollection new. acceptableTypes _ Set withAll: EToyIncomingMessage allTypes. ! ! !EToyGateKeeperEntry class methodsFor: 'new-morph participation' stamp: 'RAA 8/3/2000 07:48'! includeInNewMorphMenu "Not to be instantiated from the menu" ^ false! ! !EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ #raised! ! !EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !EToyGateKeeperMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:42'! initialize "initialize the state of the receiver" super initialize. "" self listDirection: #topToBottom; layoutInset: 4; hResizing: #spaceFill; vResizing: #spaceFill; useRoundedCorners; rebuild ! ! !EToyGateKeeperMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 11:57'! entryForIPAddress: ipAddressString | known entry | UpdateCounter _ self updateCounter + 1. known _ self knownIPAddresses. entry _ known at: ipAddressString ifAbsentPut: [ entry _ EToyGateKeeperEntry new. entry ipAddress: ipAddressString. entry ]. ^entry! ! !EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 7/12/2003 12:33'! genericTextFieldNamed: aString | newField | newField := ShowEmptyTextMorph new beAllFont: self myFont; extent: 400 @ 20; contentsWrapped: ''. namedFields at: aString put: newField. ^ newField! ! !EToyGenericDialogMorph methodsFor: 'as yet unclassified' stamp: 'dgd 7/12/2003 12:29'! myFont ^ Preferences standardEToysFont! ! !EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:54'! initialize "initialize the state of the receiver" super initialize. "" namedFields _ Dictionary new. self rebuild! ! !EToyGenericDialogMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 18:05'! rebuild "rebuilds the receiver" ^ self! ! !EToyHierarchicalTextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !EToyHierarchicalTextMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:27'! initialize "initialize the state of the receiver" super initialize. self useRoundedCorners! ! !EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 17:57'! addNewObject: newObject thumbForm: aForm sentBy: senderName ipAddress: ipAddressString | thumb row | thumb _ aForm asMorph. thumb setProperty: #depictedObject toValue: newObject. row _ self addARow: { thumb. self inAColumn: { StringMorph new contents: senderName; lock. StringMorph new contents: ipAddressString; lock. } }. true ifTrue: [ "simpler protocol" row on: #mouseUp send: #mouseUpEvent:for: to: self. ] ifFalse: [ row on: #mouseDown send: #mouseDownEvent:for: to: self. ]. ! ! !EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/22/2003 18:59'! mouseDownEvent: event for: aMorph | menu selection depictedObject | depictedObject := aMorph firstSubmorph valueOfProperty: #depictedObject. menu := CustomMenu new. menu add: 'Grab' action: [event hand attachMorph: depictedObject veryDeepCopy]; add: 'Delete' action: [self class removeFromGlobalIncomingQueue: depictedObject. self rebuild]. selection := menu build startUpCenteredWithCaption: 'Morph from ' , (aMorph submorphs second) firstSubmorph contents. selection ifNil: [^self]. selection value! ! !EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 17:58'! mouseUpEvent: event for: aMorph | depictedObject | depictedObject _ aMorph firstSubmorph valueOfProperty: #depictedObject. event hand attachMorph: depictedObject. self class removeFromGlobalIncomingQueue: depictedObject. self rebuild. ! ! !EToyListenerMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 19:28'! rebuild | earMorph | updateCounter _ UpdateCounter. self removeAllMorphs. self addGateKeeperMorphs. GlobalListener ifNil: [ earMorph _ (self class makeListeningToggleNew: false) asMorph. earMorph setBalloonText: 'Click to START listening for messages'. earMorph on: #mouseUp send: #startListening to: self. ] ifNotNil: [ earMorph _ (self class makeListeningToggleNew: true) asMorph. earMorph setBalloonText: 'Click to STOP listening for messages'. earMorph on: #mouseUp send: #stopListening to: self. ]. self addARow: {self inAColumn: {earMorph}}. self addARow: { self inAColumn: {(StringMorph contents: 'Incoming communications') lock}. self indicatorFieldNamed: #working color: Color blue help: 'working'. self indicatorFieldNamed: #communicating color: Color green help: 'receiving'. }. "{thumbForm. newObject. senderName. ipAddressString}" self class globalIncomingQueueCopy do: [ :each | self addNewObject: each second thumbForm: each first sentBy: each third ipAddress: each fourth. ].! ! !EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color blue! ! !EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightBlue! ! !EToyListenerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:44'! initialize "initialize the state of the receiver" super initialize. "" self listDirection: #topToBottom; layoutInset: 4; rebuild ! ! !EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'RAA 5/1/2002 19:29'! makeListeningToggleNew: activeMode | background c baseExtent bgExtent botCent factor len endPts base | factor _ 2. bgExtent _ (50@25) * factor. baseExtent _ (15@15) * factor. background _ Form extent: bgExtent depth: 8. botCent _ background boundingBox bottomCenter. c _ background getCanvas. "c fillColor: Color white." base _ (botCent - (baseExtent // 2)) extent: baseExtent. c fillOval: base color: Color black borderWidth: 0 borderColor: Color black. activeMode ifTrue: [ len _ background boundingBox height - 15. endPts _ {botCent - (len@len). botCent - (len negated@len)}. endPts do: [ :each | c line: botCent to: each width: 2 color: Color black. ]. endPts do: [ :each | #(4 8 12) do: [ :offset | c frameOval: (each - offset corner: each + offset) color: Color red ]. ]. ]. "background asMorph openInWorld." ^background ! ! !EToyListenerMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/3/2001 21:54'! stopListening GlobalListener ifNotNil: [GlobalListener stopListening. GlobalListener _ nil. self bumpUpdateCounter] "EToyListenerMorph stopListening"! ! !EToyListenerMorph class methodsFor: 'class initialization' stamp: 'ads 7/18/2003 09:07'! unload Smalltalk removeFromStartUpList: self. Smalltalk removeFromShutDownList: self. ! ! !EToyListenerMorph class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:51'! descriptionForPartsBin ^ self partName: 'Listener' categories: #('Collaborative') documentation: 'A tool for receiving things from other Squeak uers'! ! !EToyMorphsWelcomeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !EToyMorphsWelcomeMorph methodsFor: 'initialization' stamp: 'nk 7/12/2003 08:58'! initialize "initialize the state of the receiver" | earMorph | super initialize. "" self layoutInset: 8 @ 8. "earMorph _ (EToyListenerMorph makeListeningToggle: true) asMorph." earMorph _ TextMorph new contents: 'Morphs welcome here'; fontName: Preferences standardEToysFont familyName size: 18; centered; lock. self addARow: {earMorph}. self setBalloonText: 'My presence in this world means received morphs may appear automatically'! ! !EToyMorphsWelcomeMorph class methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 12:52'! descriptionForPartsBin ^ self partName: 'Welcome' categories: #('Collaborative') documentation: 'A sign that you accept morphs dropped directly into your world'! ! !EToyMultiChatMorph class methodsFor: 'parts bin' stamp: 'RAA 1/28/2002 15:32'! descriptionForPartsBin ^ self partName: 'Text chat+' categories: #('Collaborative') documentation: 'A tool for sending messages to several Squeak users at once' sampleImageForm: (Form extent: 25@25 depth: 16 fromArray: #( 1177640695 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593270007 1593245696 1593263665 1593270007 1593270007 1593270007 1177634353 1177628012 1177628012 1177640695 1593270007 1593270007 1593278463 2147450879 1316159488 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264 1593257324 762064236 762064236 762064236 762064236 762057894 762057894 762064236 762064236 762064236 762064236 762064236 1177616384 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593278459 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 2147188731 1870200832 1593274233 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1870229369 1731723264) offset: 0@0)! ! !EToyPeerToPeer methodsFor: 'sending' stamp: 'mir 5/15/2003 18:29'! doConnectForSend | addr | addr _ NetNameResolver addressForName: ipAddress. addr ifNil: [ communicatorMorph commResult: {#message -> ('could not find ',ipAddress)}. ^false ]. socket connectNonBlockingTo: addr port: self class eToyCommunicationsPort. [socket waitForConnectionFor: 15] on: ConnectionTimedOut do: [:ex | communicatorMorph commResult: {#message -> ('no connection to ',ipAddress,' (', (NetNameResolver stringFromAddress: addr),')')}. ^false]. ^true ! ! !EToyPeerToPeer methodsFor: 'receiving' stamp: 'mir 5/15/2003 15:40'! doReceiveOneMessage | awaitingLength i length answer | awaitingLength _ true. answer _ WriteStream on: String new. [awaitingLength] whileTrue: [ leftOverData _ leftOverData , socket receiveData. (i _ leftOverData indexOf: $ ) > 0 ifTrue: [ awaitingLength _ false. length _ (leftOverData first: i - 1) asNumber. answer nextPutAll: (leftOverData allButFirst: i). ]. ]. leftOverData _ ''. [answer size < length] whileTrue: [ answer nextPutAll: socket receiveData. communicatorMorph commResult: {#commFlash -> true}. ]. answer _ answer contents. answer size > length ifTrue: [ leftOverData _ answer allButFirst: length. answer _ answer first: length ]. ^answer ! ! !EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'ar 2/23/2001 20:56'! copyOutDetails | newDetails | newDetails _ Dictionary new. self fieldToDetailsMappings do: [ :each | namedFields at: each first ifPresent: [ :field | newDetails at: each second put: field contents string ]. ]. namedFields at: 'projectname' ifPresent: [ :field | newDetails at: 'projectname' put: field contents string withBlanksTrimmed. ]. ^newDetails! ! !EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/23/2005 17:24'! expandButton ^self buttonNamed: 'More' translated action: #doExpand color: self buttonColor help: 'Show more info on this project.' translated. ! ! !EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'dgd 3/16/2004 12:10'! expandedFormat ^ Preferences expandedPublishing or: [self valueOfProperty: #expandedFormat ifAbsent: [false]] ! ! !EToyProjectDetailsMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/2/2003 19:39'! rebuild | bottomButtons | self removeAllMorphs. self addARow: { self lockedString: 'Please describe this project' translated. }. self addARow: { self lockedString: 'Name:' translated. self inAColumnForText: {self fieldForProjectName} }. self expandedFormat ifTrue: [ self fieldToDetailsMappings do: [ :each | self addARow: { self lockedString: each third translated. self inAColumnForText: {(self genericTextFieldNamed: each first) height: each fourth} }. ]. ]. bottomButtons _ self expandedFormat ifTrue: [ { self okButton. self cancelButton. } ] ifFalse: [ { self okButton. self expandButton. self cancelButton. } ]. self addARow: bottomButtons. self fillInDetails.! ! !EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'mir 6/19/2001 10:17'! getFullInfoFor: aProject ifValid: aBlock expandedFormat: expandedFormat | me | (me _ self basicNew) expandedFormat: expandedFormat; project: aProject actionBlock: [ :x | aProject world setProperty: #ProjectDetails toValue: x. x at: 'projectname' ifPresent: [ :newName | aProject renameTo: newName. ]. me delete. aBlock value. ]; initialize; openCenteredInWorld! ! !EToyProjectDetailsMorph class methodsFor: 'as yet unclassified' stamp: 'mir 6/19/2001 10:17'! test1: aProject "EToyProjectDetailsMorph test1: Project current" (self basicNew) project: aProject actionBlock: [ :x | aProject world setProperty: #ProjectDetails toValue: x. x at: 'projectname' ifPresent: [ :newName | aProject renameTo: newName. ] ]; initialize; openCenteredInWorld! ! !EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! mouseUp: evt in: aMorph | tuple project url | (aMorph boundsInWorld containsPoint: evt cursorPoint) ifFalse: [^self]. tuple _ aMorph valueOfProperty: #projectParametersTuple ifAbsent: [^Beeper beep]. project _ tuple fourth first. (project notNil and: [project world notNil]) ifTrue: [self closeMyFlapIfAny. ^project enter]. url _ tuple third. url isEmptyOrNil ifTrue: [^Beeper beep]. self closeMyFlapIfAny. ProjectLoading thumbnailFromUrl: url. "--- newTuple _ { aProject name. aProject thumbnail. aProject url. WeakArray with: aProject. }. ---"! ! !EToyProjectHistoryMorph methodsFor: 'as yet unclassified' stamp: 'dgd 9/20/2003 18:52'! rebuild | history r1 | history _ ProjectHistory currentHistory mostRecentCopy. changeCounter _ ProjectHistory changeCounter. self removeAllMorphs. self rubberBandCells: false. "enable growing" r1 _ self addARow: { self inAColumn: { StringMorph new contents: 'Jump...' translated; lock. }. }. r1 on: #mouseUp send: #jumpToProject to: self. history do: [ :each | ( self addARow: { (self inAColumn: { StretchyImageMorph new form: each second; minWidth: 35; minHeight: 35; lock }) vResizing: #spaceFill. self inAColumn: { StringMorph new contents: each first; lock. "StringMorph new contents: each third; lock." }. } ) color: Color paleYellow; borderWidth: 1; borderColor: #raised; vResizing: #spaceFill; on: #mouseUp send: #mouseUp:in: to: self; on: #mouseDown send: #mouseDown:in: to: self; on: #mouseMove send: #mouseMove:in: to: self; on: #mouseLeave send: #mouseLeave:in: to: self; setProperty: #projectParametersTuple toValue: each; setBalloonText: (each third isEmptyOrNil ifTrue: ['not saved'] ifFalse: [each third]) ]. "--- newTuple _ { aProject name. aProject thumbnail. aProject url. WeakArray with: aProject. }. ---"! ! !EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ #raised! ! !EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:25'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightBrown! ! !EToyProjectHistoryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:46'! initialize "initialize the state of the receiver" super initialize. "" self listDirection: #topToBottom; layoutInset: 4; hResizing: #shrinkWrap; vResizing: #shrinkWrap; useRoundedCorners; rebuild ! ! !EToyProjectHistoryMorph class methodsFor: 'parts bin' stamp: 'sw 8/19/2001 21:15'! descriptionForPartsBin ^ self partName: 'ProjectHistory' categories: #('Navigation') documentation: 'A tool that lets you navigate back to recently-visited projects'! ! !EToyProjectQueryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self color darker! ! !EToyProjectQueryMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.545 g: 0.47 b: 0.621! ! !EToyProjectQueryMorph class methodsFor: 'as yet unclassified' stamp: 'mir 11/14/2001 16:29'! onServer: aProjectServer "EToyProjectQueryMorph onServer: SuperSwikiServer testOnlySuperSwiki" | criteria clean | (self basicNew) project: nil actionBlock: [ :x | criteria _ OrderedCollection new. x keysAndValuesDo: [ :k :v | (clean _ v withBlanksTrimmed) isEmpty ifFalse: [criteria add: k,': *',clean,'*']]. aProjectServer queryProjectsAndShow: criteria]; initialize; openCenteredInWorld! ! !EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'jm 9/2/2003 19:39'! buttonNamed: aString action: aSymbol color: aColor help: helpString | f col | f _ SimpleButtonMorph new target: self; label: aString translated font: self myFont; color: aColor; actionSelector: aSymbol; setBalloonText: helpString translated. col _ (self inAColumn: {f}) hResizing: #spaceFill. ^col! ! !EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'ar 2/23/2001 20:55'! doOK self validateTheProjectName ifFalse: [^self]. self delete. actionBlock value: (namedFields at: 'projectname') contents string withBlanksTrimmed.! ! !EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/23/2005 17:25'! fieldForProjectName | tm | tm _ self genericTextFieldNamed: 'projectname'. tm crAction: (MessageSend receiver: self selector: #doOK). tm setBalloonText: 'Pick a name 24 characters or less and avoid the following characters: : < > | / \ ? * " .' translated. ^tm ! ! !EToyProjectRenamerMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 18:53'! validateTheProjectName | proposed | proposed _ (namedFields at: 'projectname') contents string withBlanksTrimmed. proposed isEmpty ifTrue: [ self inform: 'I do need a name for the project' translated. ^false ]. proposed size > 24 ifTrue: [ self inform: 'Please make the name 24 characters or less' translated. ^false ]. (Project isBadNameForStoring: proposed) ifTrue: [ self inform: 'Please remove any funny characters from the name' translated. ^false ]. proposed = theProject name ifTrue: [^true]. (ChangeSorter changeSetNamed: proposed) ifNotNil: [ Utilities inform: 'Sorry that name is already used' translated. ^false ]. ^true! ! !EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ color darker! ! !EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 8! ! !EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ! !EToyProjectRenamerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:54'! initialize "initialize the state of the receiver" super initialize. "" self vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 4; useRoundedCorners; rebuild! ! !EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'nk 6/12/2004 09:23'! fixOldVersion | uName uForm uEmail uIP | uName _ self userName. uForm _ userPicture ifNil: [ (self findDeepSubmorphThat: [ :x | (x isKindOf: ImageMorph) or: [x isSketchMorph]] ifAbsent: [self halt]) form. ]. uEmail _ (fields at: #emailAddress) contents. uIP _ self ipAddress. self userName: uName userPicture: (uForm scaledToSize: 61@53) userEmail: uEmail userIPAddress: uIP ! ! !EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'aoy 2/15/2003 20:59'! startAudioChat: toggleMode | chat r | (self valueOfProperty: #embeddedAudioChatHolder) ifNotNil: [toggleMode ifFalse: [^self]. ^self killExistingChat]. chat := AudioChatGUI new ipAddress: self ipAddress. (self ownerThatIsA: EToyFridgeMorph) isNil ifTrue: [chat removeConnectButton; vResizing: #shrinkWrap; hResizing: #shrinkWrap; borderWidth: 2. "we already know the connectee" r := (self addARow: { chat}) vResizing: #shrinkWrap. self world startSteppingSubmorphsOf: chat. self setProperty: #embeddedAudioChatHolder toValue: r. self hResizing: #shrinkWrap; vResizing: #shrinkWrap] ifFalse: [chat openInWorld: self world]! ! !EToySenderMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/20/2001 13:03'! userName ^ (self findDeepSubmorphThat: [ :x | x isKindOf: StringMorph] ifAbsent: [^nil]) contents ! ! !EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color magenta! ! !EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightMagenta! ! !EToySenderMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:58'! initialize "initialize the state of the receiver" Socket initializeNetwork. "we may want our IP address" Preferences defaultAuthorName. "seems like a good place to insure we have a name" super initialize. "" self listDirection: #topToBottom; layoutInset: 4; setProperty: #normalBorderColor toValue: self borderColor; setProperty: #flashingColors toValue: {Color red. Color yellow}! ! !EToySenderMorph methodsFor: 'layout' stamp: 'RAA 3/7/2001 22:31'! acceptDroppingMorph: morphToDrop event: evt | myCopy outData | (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these" ^morphToDrop rejectDropMorphEvent: evt. ]. self eToyRejectDropMorph: morphToDrop event: evt. "we don't really want it" "7 mar 2001 - remove #veryDeepCopy" myCopy _ morphToDrop. "gradient fills require doing this second" myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position. self stopFlashing. outData _ myCopy eToyStreamedRepresentationNotifying: self. self resetIndicator: #working. self transmitStreamedObject: outData to: self ipAddress. ! ! !EToySenderMorph methodsFor: 'parts bin' stamp: 'RAA 8/20/2001 13:08'! initializeToStandAlone super initializeToStandAlone. self installModelIn: ActiveWorld. ! ! !EToySenderMorph class methodsFor: 'parts bin' stamp: 'RAA 12/18/2001 10:05'! descriptionForPartsBin ^ self partName: 'Badge' categories: #('Collaborative') documentation: 'A tool for collaborating with other Squeak users' sampleImageForm: (Form extent: 66@72 depth: 16 fromArray: #( 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 2134867775 2134842568 2134867775 2134867775 2134867775 1032879935 2134867775 2134867775 2134867775 2134867775 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134842568 1032871511 1032863120 1582775696 1032871511 2134867775 2134867775 1032871511 2134842568 1032863120 482885008 1032879935 482901823 482885008 1032879935 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134850960 1032879935 1032863120 2134850960 2134867775 2134859351 482876616 2134850960 2134867775 1032879935 1032879935 1032879935 1032879935 1032879935 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1582767304 1032871511 1032863120 1582775696 1032871511 2134867775 2134842568 1582767304 1582767304 1582792511 482893399 482893399 482893399 482893399 482893399 1032863120 1582792511 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1032863120 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 65537 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032863120 1032863120 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 1032847361 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 65537 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 81296 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134835201 98111 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134850960 1032879935 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 1039171583 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1039154672 2147433968 1039154672 1593270007 1039163127 1593278463 1593261552 2147442423 1593270007 1593261552 2147450879 2147442423 1593270007 2147442423 1039171583 484990711 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039163127 1039171583 1039163127 1039171583 1039171583 1039154672 1039154672 1039163127 1039163127 1039171583 1039163127 1039171583 484982256 1039146216 1593270007 484982256 1039171583 2147425512 1593261552 2147425512 1039154672 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039154672 1593278463 1039171583 1039171583 1039171583 1039154672 1039146216 1593278463 1039154672 1593278463 1039171583 1039171583 1039171583 1593261552 2147450879 1039171583 1593270007 2147433968 2147433968 2147433968 2147442423 1039171583 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1593270007 2147450879 1039163127 1039163127 1593261552 2147442423 1039163127 2147450879 1593270007 2147450879 1039163127 1039163127 1593261552 2147433968 1593278463 1593261552 2147442423 2147433968 1593261552 1593270007 1039171583 2147442423 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2141159231 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 1039171583 1593261552 2147442423 1039171583 2147450879 2147442423 2147450879 1593278463 1593261552 2147450879 2147442423 1039171583 2147442423 2147450879 2147442423 1039171583 2147442423 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141150967 2147433968 1039171583 1039154672 2147433968 2147450879 1593261552 2147442423 1039171583 1593278463 1039171583 2147433968 2147433968 1593261552 2147450879 2147442423 2147433968 1593261552 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 1039171583 1039171583 1039154672 1039154672 2147450879 2147433968 2147425512 484990711 2147433968 1593278463 2147433968 1039154672 2147433968 2147450879 2147450879 1039163127 484973800 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 2147442423 1039171583 1039171583 1593270007 1593278463 2147433968 2147450879 1039171583 2147450879 1039163127 2147450879 1593270007 2147433968 2147442423 2147450879 2147433968 2147433968 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141142512 1039163127 1593261552 2147442423 1593278463 1593278463 1593261552 2147450879 1039163127 1593261552 2147442423 2147442423 1593278463 1593261552 2147442423 2147442423 1039171583 2147433968 1593278367 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2141159423 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450879 2147450783 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 1729849115 2134867775 2134867775 2134861595 1729855295 2134867775 2134867775 1729843959 1391951679 2134867775 2134867775 2134856439 1729855295 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1326930843 1879001943 1729855295 2134861595 1398112251 1738035990 2134867775 2134855446 1536646039 1326874431 2134867775 1387357800 1718112945 2134867775 2134856463 1736736736 2145407816 1729855295 2134861595 1398243327 1738232599 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134856439 1879011327 1879011327 1264025407 2134856533 2147188731 2147188731 1391951679 1391947770 1878683642 1878676215 2134856439 2120646246 2120646246 1391951679 1391951840 2145419232 2145419232 1397260095 2134856535 2147450879 2147450879 1391951679 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 484908263 1039040507 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 1025736294 1384873791 1397260256 2145402336 2145419232 2145407735 1391951871 1039154672 1039171583 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 1879003895 1391951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120646246 1025736294 1384873791 1397260256 1591754208 2145419232 2145407735 1391951871 1039163127 2147450879 1398243135 2134867775 2082438175 2082438175 2134867775 2134835216 2031647 2031632 2134835680 65012704 65012192 2134854487 904949759 1879011327 1879003895 1391951867 2147171822 2147188731 1398112063 1263890426 904753146 1878674261 2134856331 2120629539 2120646246 1384873791 1397260256 484449504 1591771104 2145407735 1391951871 2147442423 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134842568 1507359 1514696 2134842568 48235488 48241864 2134854487 1391932912 904949759 1879003895 1391951867 1593056487 2147188731 1398112063 1263890426 1391685626 1878674261 2134856331 2120637892 2120646246 1384873791 1397251808 484466400 484474848 2145407735 1391951871 484982256 1593278463 1398243135 2134867775 2082438175 2082438175 2134867775 2134867775 1032863120 1032879935 2134867775 1032863120 1032879935 2134855447 1879011327 1879011327 1536911131 1729849240 2147188731 2147188731 1393983295 1326870522 1878683642 1878675222 2134856369 2120646246 2120646246 1387364159 1393524704 2145419232 2145419232 1736730395 1729849243 2147450879 2147450879 1394048831 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134861595 1536913407 1879011327 1326939967 2134856470 2147188731 2147182488 1729855295 1729846167 1878683642 1536648987 2134861595 1718124134 2120640104 1729855295 1729849220 2145419232 2145419232 1393524543 2134856471 2147450879 2147444635 1729855295 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 1729842967 1264014071 2134867775 2134867775 1391940437 1393977115 2134867775 2134861595 1326862102 1729855295 2134867775 1729843889 1387357979 2134867775 2134861595 1393513288 1397248759 2134867775 2134867775 1391940439 1394042651 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 2082438175 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082438175 1545042975 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2134867775 2082429975 470252575 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082413575 7175 1545042975 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082438175 2082429975 470220800) offset: 0@0)! ! !EToySystem class methodsFor: 'development support' stamp: 'sd 5/11/2003 22:13'! loadJanForms "EToySystem loadJanForms" | aReferenceStream newFormDict | aReferenceStream _ ReferenceStream fileNamed: 'JanForms'. newFormDict _ aReferenceStream next. aReferenceStream close. newFormDict associationsDo: [:assoc | Imports default importImage: assoc value named: assoc key]! ! !EToySystem class methodsFor: 'development support' stamp: 'sd 1/16/2004 20:55'! stripMethodsForExternalRelease "EToySystem stripMethodsForExternalRelease" SmalltalkImage current stripMethods: self methodsToStripForExternalRelease messageCode: '2.3External'! ! !EToySystem class methodsFor: 'external release' stamp: 'tk 4/10/2001 13:08'! methodsToStripForExternalRelease "Answer a list of triplets #(className, class/instance, methodName) of methods to be stripped in an external release." ^ #( (EToySystem class prepareRelease) (EToySystem class previewEToysOn:) )! ! !EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! addSibling parentWrapper ifNil: [^Beeper beep]. parentWrapper addNewChildAfter: item.! ! !EToyTextNodeWrapper methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! delete parentWrapper ifNil: [^Beeper beep]. parentWrapper withoutListWrapper removeChild: item withoutListWrapper. ! ! !EToyVectorVocabulary methodsFor: 'initialization' stamp: 'sw 9/10/2001 14:44'! addCustomCategoriesTo: categoryList "Add any further categories to the default list of viewer categories for an object" categoryList add: #vector! ! !EToyVectorVocabulary methodsFor: 'initialization' stamp: 'sw 9/26/2001 03:56'! eToyVectorTable "Answer a table of specifications to send to #addFromTable: which add the 'players are vectors' extension to the etoy vocabulary." "(selector setterOrNil ((arg name arg type)...) resultType (category ...) 'help msg' 'wording' autoUpdate)" ^ #( (+ nil ((aVector Player)) Player (geometry) 'Adds two players together, treating each as a vector from the origin.') (- nil ((aVector Player)) Player (geometry) 'Subtracts one player from another, treating each as a vector from the origin.') (* nil ((aVector Number)) Player (geometry) 'Multiply a player by a number, treating the Player as a vector from the origin.') (/ nil ((aVector Number)) Player (geometry) 'Divide a player by a Number, treating the Player as a vector from the origin.') (incr: nil ((aVector Player)) unknown (geometry) 'Each Player is a vector from the origin. Increase one by the amount of the other.' 'increase by') (decr: nil ((aVector Player)) unknown (geometry) 'Each Player is a vector from the origin. Decrease one by the amount of the other.' 'decrease by') (multBy: nil ((factor Number)) unknown (geometry) 'A Player is a vector from the origin. Multiply its length by the factor.' 'multiplied by') (dividedBy: nil ((factor Number)) unknown (geometry) 'A Player is a vector from the origin. Divide its length by the factor.' 'divided by') "distance and theta are already in Player. See additionsToViewerCategoryGeometry" ).! ! !EToyVectorVocabulary methodsFor: 'initialization' stamp: 'mir 7/15/2004 19:29'! initialize "Initialize the vocabulary" super initialize. self addFromTable: self eToyVectorTable. self vocabularyName: #Vector. self documentation: 'This vocabulary adds to the basic etoy experience an interpretation of "players are vectors", requested by Alan Kay and implemented by Ted Kaehler in summer 2001'. ! ! !EToyVectorVocabulary methodsFor: 'method list' stamp: 'sw 9/13/2001 17:26'! allMethodsInCategory: aCategorySymbol forInstance: anObject ofClass: aClass "Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass" | likelyReply | likelyReply _ super allMethodsInCategory: aCategorySymbol forInstance: anObject ofClass: aClass. ^ ((anObject isKindOf: Player) and: [aCategorySymbol == #vector]) ifFalse: [likelyReply] ifTrue: [anObject costume class vectorAdditions collect: [:anAddition | (self methodInterfaceFrom: anAddition) selector]]! ! !EToyVectorVocabulary commentStamp: '' prior: 0! An extension of the etoy vocabulary in support of an experiment Alan Kay requested in summer 2001 for allowing any morph/player to be thought of as a vector. In effect, adds a category #vector to the viewer for such all morphs. Consult Ted Kaehler and Alan Kay for more information on this track.! !EToyVocabulary methodsFor: 'initialization' stamp: 'sw 9/13/2001 16:36'! addCustomCategoriesTo: categoryList "Add any further categories to the categoryList -- for benefit of subclasses wishing to override."! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'sw 9/13/2001 16:39'! methodInterfaceFrom: elementTuple "Tedious revectoring: The argument is a tuple of the sort that #additionsToViewerCategory: answers a list of; answer a MethodInterface" ^ elementTuple first == #command ifTrue: [MethodInterface new initializeFromEToyCommandSpec: elementTuple category: nil] ifFalse: "#slot format" [MethodInterface new initializeFromEToySlotSpec: elementTuple]! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'RAA 6/4/2001 19:12'! objectForDataStream: refStrm "I am about to be written on an object file. Write a path to me in the other system instead." vocabularyName == #eToy ifFalse: [^ self]. ^ DiskProxy global: #Vocabulary selector: #vocabularyNamed: args: (Array with: vocabularyName) ! ! !EToyVocabulary methodsFor: 'initialization' stamp: 'nk 10/6/2004 11:56'! setCategoryDocumentationStrings "Initialize the documentation strings associated with the old etoy categories, in English" self setCategoryStrings: #( (basic 'basic' 'a few important things') (#'book navigation' 'book navigation' 'relating to book, stacks, etc') (button 'button' 'for thinking of this object as a push-button control') (collections 'collections' 'for thinking of this object as a collection') (fog 'fog' '3D fog') (geometry 'geometry' 'measurements and coordinates') (#'color & border' 'color & border' 'matters concerning the colors and borders of objects') (graphics 'graphics' 'for thinking of this object as a picture') (variables 'variables' 'variables added by this object') (joystick 'joystick' 'the object as a Joystick') (miscellaneous 'miscellaneous' 'various commands') (motion 'motion' 'matters relating to moving and turning') (paintbox 'paintbox' 'the painting palette') (#'pen trails' 'pen trails' 'relating to trails put down by pens') (#'pen use' 'pen use' 'use of an object''s "pen"') (playfield 'playfield' 'the object as a container for other visible objects') (sampling 'sampling' 'sampling') (scripting 'scripting' 'commands to start and stop scripts') (scripts 'scripts' 'methods added by this object') (slider 'slider' 'functions useful to sliders') (speaker 'speaker' 'the object as an audio Speaker') (#'stack navigation' 'stack navigation' 'navigation within a stck') (storyboard 'storyboard' 'storyboard') (tests 'tests' 'yes/no tests, to use in "Test" panes of scripts') (text 'text' 'The object as text') (vector 'vector' 'The object as a vector') (viewing 'viewing' 'matters relating to viewing') ) ! ! !EToyVocabulary methodsFor: 'category list' stamp: 'nk 8/29/2004 17:17'! categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass "Answer the category list for the given object, considering only code implemented in aClass and lower" ^ (anObject isPlayerLike) ifTrue: [self flag: #deferred. "The bit commented out on next line is desirable but not yet workable, because it delivers categories that are not relevant to the costume in question" "#(scripts #'instance variables'), (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass)]" self translatedWordingsFor: ((mostGenericClass == aClass) ifFalse: [anObject categoriesForVocabulary: self] ifTrue: [{ScriptingSystem nameForScriptsCategory. ScriptingSystem nameForInstanceVariablesCategory}])] ifFalse: [super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass]! ! !EToyVocabulary methodsFor: 'method list' stamp: 'sw 4/15/2003 23:42'! allMethodsInCategory: aCategoryName forInstance: anObject ofClass: aClass "Answer a list of all methods in the etoy interface which are in the given category, on behalf of anObject, or if it is nil, aClass" | aCategory unfiltered suitableSelectors isAll | aCategoryName ifNil: [^ OrderedCollection new]. aClass isUniClass ifTrue: [aCategoryName = ScriptingSystem nameForScriptsCategory ifTrue: [^ aClass namedTileScriptSelectors]. aCategoryName = ScriptingSystem nameForInstanceVariablesCategory ifTrue: [^ aClass slotInfo keys asSortedArray collect: [:anInstVarName | Utilities getterSelectorFor: anInstVarName]]]. unfiltered _ (isAll _ aCategoryName = self allCategoryName) ifTrue: [methodInterfaces collect: [:anInterface | anInterface selector]] ifFalse: [aCategory _ categories detect: [:cat | cat categoryName == aCategoryName] ifNone: [^ OrderedCollection new]. aCategory elementsInOrder collect: [:anElement | anElement selector]]. (anObject isKindOf: Player) ifTrue: [suitableSelectors _ anObject costume selectorsForViewer. unfiltered _ unfiltered select: [:aSelector | suitableSelectors includes: aSelector]]. (isAll and: [aClass isUniClass]) ifTrue: [unfiltered addAll: aClass namedTileScriptSelectors. unfiltered addAll: (aClass slotInfo keys asSortedArray collect: [:anInstVarName | Utilities getterSelectorFor: anInstVarName])]. ^ (unfiltered copyWithoutAll: #(dummy unused)) asSortedArray! ! !EToyVocabulary methodsFor: 'method list' stamp: 'sw 11/3/2004 20:13'! masterOrderingOfPhraseSymbols "Answer a dictatorially-imposed presentation list of phrase-symbols. This governs the order in which suitable phrases are presented in etoy viewers using the etoy vocabulary. For any given category, the default implementation is that any items that are in this list will occur first, in the order specified here; after that, all other items will come, in alphabetic order by formal selector." ^ #(beep: forward: turn: getX getY getLocationRounded getHeading getScaleFactor getLeft getRight getTop getBottom getLength getWidth getTheta getDistance getHeadingTheta getUnitVector startScript: pauseScript: stopScript: startAll: pauseAll: stopAll: tellAllSiblings: doScript: getColor getUseGradientFill getSecondColor getRadialGradientFill getBorderWidth getBorderColor getBorderStyle getRoundedCorners getDropShadow getShadowColor getVolume play playUntilPosition: stop rewind getIsRunning getRepeat getPosition getTotalFrames getTotalSeconds getFrameGraphic getVideoFileName getSubtitlesFileName getGraphic getBaseGraphic #getAutoExpansion #getAutoLineLayout #getBatchPenTrails #getFenceEnabled #getIndicateCursor #getIsOpenForDragNDrop #getIsPartsBin #getMouseOverHalos #getOriginAtCenter #getShowThumbnail)! ! !EToyVocabulary methodsFor: 'method list' stamp: 'sw 7/14/2004 18:24'! phraseSymbolsToSuppress "Answer a dictatorially-imposed list of phrase-symbols that are to be suppressed from viewers when the eToyFriendly preference is set to true. This list at the moment corresponds to the wishes of Alan and Kim and the LA teachers using Squeak in school-year 2001-2" ^ Preferences eToyFriendly ifTrue: [#(moveToward: followPath goToRightOf: getViewingByIcon initiatePainting append: prepend: getClipSubmorphs touchesA:)] ifFalse: [#()]! ! !EToyVocabulary methodsFor: '*flexiblevocabularies-initialization' stamp: 'nk 9/11/2004 18:04'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" | classes aMethodCategory selector selectors categorySymbols aMethodInterface | super initialize. self vocabularyName: #eToy. self documentation: '"EToy" is a vocabulary that provides the equivalent of the 1997-2000 etoy prototype'. categorySymbols _ Set new. classes _ self class morphClassesDeclaringViewerAdditions. classes do: [:aMorphClass | categorySymbols addAll: aMorphClass unfilteredCategoriesForViewer]. self addCustomCategoriesTo: categorySymbols. "For benefit, e.g., of EToyVectorVocabulary" categorySymbols asOrderedCollection do: [:aCategorySymbol | aMethodCategory _ ElementCategory new categoryName: aCategorySymbol. selectors _ Set new. classes do: [:aMorphClass | (aMorphClass additionsToViewerCategory: aCategorySymbol) do: [:anElement | aMethodInterface _ self methodInterfaceFrom: anElement. selectors add: (selector _ aMethodInterface selector). (methodInterfaces includesKey: selector) ifFalse: [methodInterfaces at: selector put: aMethodInterface]. self flag: #deferred. "NB at present, the *setter* does not get its own method interface. Need to revisit"]. (selectors copyWithout: #unused) asSortedArray do: [:aSelector | aMethodCategory elementAt: aSelector put: (methodInterfaces at: aSelector)]]. self addCategory: aMethodCategory]. self addCategoryNamed: ScriptingSystem nameForInstanceVariablesCategory. self addCategoryNamed: ScriptingSystem nameForScriptsCategory. self setCategoryDocumentationStrings. (self respondsTo: #applyMasterOrdering) ifTrue: [ self applyMasterOrdering ].! ! !EToyVocabulary methodsFor: '*flexibleVocabularies-testing' stamp: 'nk 8/29/2004 17:20'! isEToyVocabulary ^true! ! !EToyVocabulary class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 10/8/2004 16:21'! masterOrderingOfCategorySymbols "Answer a dictatorially-imposed presentation list of category symbols. This governs the order in which available vocabulary categories are presented in etoy viewers using the etoy vocabulary. The default implementation is that any items that are in this list will occur first, in the order specified here; after that, all other items will come, in alphabetic order by their translated wording." ^#(basic #'color & border' geometry motion #'pen use' tests layout #'drag & drop' scripting observation button search miscellaneous)! ! !EToyVocabulary class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 7/3/2003 20:07'! morphClassesDeclaringViewerAdditions "Answer a list of actual morph classes that either implement #additionsToViewerCategories, or that have methods that match #additionToViewerCategory* ." ^(Morph class allSubInstances select: [ :ea | ea hasAdditionsToViewerCategories ]) ! ! !EToyVocabulary class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 18:00'! vocabularySummary "Answer a string describing all the vocabulary defined anywhere in the system." " (StringHolder new contents: EToyVocabulary vocabularySummary) openLabel: 'EToy Vocabulary' translated " | etoyVocab rt interfaces allAdditions | etoyVocab := Vocabulary eToyVocabulary. etoyVocab initialize. "just to make sure that it's unfiltered." ^ String streamContents: [:s | self morphClassesDeclaringViewerAdditions do: [:cl | s nextPutAll: cl name; cr. allAdditions := cl allAdditionsToViewerCategories. cl unfilteredCategoriesForViewer do: [ :cat | allAdditions at: cat ifPresent: [ :additions | interfaces := ((etoyVocab categoryAt: cat) ifNil: [ ElementCategory new ]) elementsInOrder. interfaces := interfaces select: [:ea | additions anySatisfy: [:tuple | (tuple first = #slot ifTrue: [tuple at: 7] ifFalse: [tuple at: 2]) = ea selector]]. s tab; nextPutAll: cat translated; cr. interfaces do: [:if | s tab: 2. rt := if resultType. rt = #unknown ifTrue: [s nextPutAll: 'command' translated] ifFalse: [s nextPutAll: 'property' translated; nextPut: $(; nextPutAll: (if companionSetterSelector ifNil: ['RO'] ifNotNil: ['RW']) translated; space; nextPutAll: rt translated; nextPutAll: ') ']. s tab; print: if wording; space. if argumentVariables do: [:av | s nextPutAll: av variableName; nextPut: $(; nextPutAll: av variableType asString; nextPut: $)] separatedBy: [s space]. s tab; nextPutAll: if helpMessage; cr]]]]]! ! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ JapaneseEnvironment. ! ! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! leadingChar ^ JISX0208 leadingChar ! ! !EUCJPTextConverter commentStamp: '' prior: 0! Text converter for Japanese variation of EUC.! !EUCJPTextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:00'! encodingNames ^ #('euc-jp' 'eucjp') copy ! ! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ KoreanEnvironment. ! ! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 15:19'! leadingChar ^ KSX1001 leadingChar ! ! !EUCKRTextConverter commentStamp: '' prior: 0! Text converter for Korean variation of EUC.! !EUCKRTextConverter class methodsFor: 'utilities' stamp: 'yo 2/17/2004 18:45'! encodingNames ^ #('euc-kr' 'ks-c-5601-1987' 'euckr') copy ! ! !EUCTextConverter methodsFor: 'conversion' stamp: 'ei 2/3/2005 20:10'! nextFromStream: aStream | character1 character2 offset value1 value2 nonUnicodeChar | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. character1 asciiValue <= 127 ifTrue: [^ character1]. character2 _ aStream basicNext. character2 = nil ifTrue: [^ nil]. offset _ 16rA1. value1 _ character1 asciiValue - offset. value2 _ character2 asciiValue - offset. (value1 < 0 or: [value1 > 93]) ifTrue: [^ nil]. (value2 < 0 or: [value2 > 93]) ifTrue: [^ nil]. nonUnicodeChar _ MultiCharacter leadingChar: self leadingChar code: value1 * 94 + value2. ^ MultiCharacter leadingChar: self languageEnvironment leadingChar code: nonUnicodeChar asUnicode. ! ! !EUCTextConverter methodsFor: 'conversion' stamp: 'yo 3/17/2004 16:23'! nextPut: aCharacter toStream: aStream | value leadingChar nonUnicodeChar value1 value2 | aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ aStream basicNextPut: aCharacter. ^ aStream ]. aCharacter class == MultiCharacter ifTrue: [ aStream nextInt32Put: aCharacter value. ^ aStream ] ]. value _ aCharacter charCode. leadingChar _ aCharacter leadingChar. (leadingChar = 0 and: [value < 128]) ifTrue: [ aStream basicNextPut: (Character value: value). ^ aStream ]. (128 <= value and: [value < 256]) ifTrue: [^ aStream]. aCharacter isUnicode ifTrue: [ nonUnicodeChar _ self nonUnicodeClass charFromUnicode: value. ] ifFalse: [ nonUnicodeChar _(Character value: value) ]. nonUnicodeChar ifNotNil: [ value _ nonUnicodeChar charCode. value1 _ value // 94 + 161. value2 _ value \\ 94 + 161. aStream basicNextPut: (Character value: value1). aStream basicNextPut: (Character value: value2). ^ aStream ] ! ! !EUCTextConverter methodsFor: 'friend' stamp: 'yo 1/18/2004 15:10'! restoreStateOf: aStream with: aConverterState aStream position: aConverterState. ! ! !EUCTextConverter methodsFor: 'friend' stamp: 'yo 1/18/2004 15:10'! saveStateOf: aStream ^ aStream position. ! ! !EUCTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:40'! languageEnvironment self subclassResponsibility ! ! !EUCTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! leadingChar ^ self subclassResponsibility ! ! !EUCTextConverter methodsFor: 'private' stamp: 'yo 10/4/2003 15:48'! nonUnicodeClass ^ (EncodedCharSet charsetAt: self leadingChar). ! ! !EUCTextConverter commentStamp: '' prior: 0! Text converter for Extended Unix Character. This is an abstract class. The CJK variations are implemented as subclasses.! !ElementCategory methodsFor: 'elements' stamp: 'sw 9/12/2001 22:59'! elementSymbol "Answer the element symbol for the receiver. Here, the categoryName dominates" ^ categoryName! ! !ElementCategory methodsFor: 'elements' stamp: 'sw 4/3/2001 11:06'! fasterElementAt: sym put: element "Add symbol at the end of my sorted list and put the element in the dictionary. This variant adds the key at the end of the keys list without checking whether it already exists." keysInOrder add: sym. ^ elementDictionary at: sym put: element! ! !ElementCategory methodsFor: 'elements' stamp: 'sw 4/11/2001 20:08'! removeElementAt: aKey "Remove the element at the given key" elementDictionary removeKey: aKey ifAbsent: [^ self]. keysInOrder remove: aKey ifAbsent: []! ! !ElementCategory methodsFor: 'initialization' stamp: 'sw 3/30/2001 00:12'! addCategoryItem: anItem "Add the item at the end, obtaining its key from itself (it must respond to #categoryName)" self elementAt: anItem categoryName put: anItem! ! !ElementCategory methodsFor: 'initialization' stamp: 'sw 3/28/2001 19:46'! clear "Clear the receiber's keysInOrder and elementDictionary" keysInOrder _ OrderedCollection new. elementDictionary _ IdentityDictionary new! ! !ElementCategory methodsFor: 'initialization' stamp: 'sw 3/28/2001 19:47'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self clear! ! !ElementCategory methodsFor: 'translation' stamp: 'dgd 12/4/2003 20:22'! translated "answer the receiver translated to the current language" ^ self class new categoryName: categoryName asString translated asSymbol! ! !ElementCategory methodsFor: 'private' stamp: 'sw 8/6/2004 10:34'! initWordingAndDocumentation "Initialize wording and documentation (helpMessage) for getters and setters" self wording: self categoryName! ! !ElementTranslation methodsFor: 'access' stamp: 'sw 8/18/2004 22:12'! helpMessage "Answer the helpMessage" ^ helpMessage! ! !EllipseMorph methodsFor: 'drawing' stamp: 'di 5/25/2001 01:37'! drawOn: aCanvas aCanvas isShadowDrawing ifTrue: [^ aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: 0 borderColor: nil]. aCanvas fillOval: bounds fillStyle: self fillStyle borderWidth: borderWidth borderColor: borderColor. ! ! !EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !EllipseMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! !EllipseMorph commentStamp: 'kfr 10/27/2003 10:32' prior: 0! A round BorderedMorph. Supports borderWidth and borderColor. Only simple borderStyle is implemented. EllipseMorph new borderWidth:10; borderColor: Color green; openInWorld. EllipseMorph new borderStyle:(SimpleBorder width: 5 color: Color blue); openInWorld.! !EllipseMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! descriptionForPartsBin ^ self partName: 'Ellipse' categories: #('Graphics' 'Basic') documentation: 'An elliptical or circular shape'! ! !EllipseMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:03'! initialize self registerInFlapsRegistry. ! ! !EllipseMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:05'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') forFlapNamed: 'Supplies'. cl registerQuad: #(EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') forFlapNamed: 'PlugIn Supplies'.]! ! !EllipseMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:33'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !EmphasizedMenu methodsFor: 'emphasis' stamp: 'fc 2/19/2004 22:07'! onlyBoldItem: itemNumber "Set up emphasis such that all items are plain except for the given item number. " emphases _ (Array new: selections size) atAllPut: #normal. emphases at: itemNumber put: #bold! ! !EmphasizedMenu methodsFor: 'private' stamp: 'fc 2/20/2004 11:01'! setEmphasis "Set up the receiver to reflect the emphases in the emphases array. " | selStart selEnd currEmphasis | labelString _ labelString asText. emphases isEmptyOrNil ifTrue: [^ self]. selStart _ 1. 1 to: selections size do: [:line | selEnd _ selStart + (selections at: line) size - 1. ((currEmphasis _ emphases at: line) size > 0 and: [currEmphasis ~~ #normal]) ifTrue: [labelString addAttribute: (TextEmphasis perform: currEmphasis) from: selStart to: selEnd]. selStart _ selEnd + 2]! ! !EmphasizedMenu class methodsFor: 'examples' stamp: 'fc 2/19/2004 22:06'! example1 "EmphasizedMenu example1" ^ (self selections: #('how' 'well' 'does' 'this' 'work?' ) emphases: #(#bold #normal #italic #struckOut #normal )) startUpWithCaption: 'A Menu with Emphases'! ! !EmphasizedMenu class methodsFor: 'examples' stamp: 'fc 2/19/2004 22:08'! example3 "EmphasizedMenu example3" ^ (self selectionAndEmphasisPairs: #('how' #bold 'well' #normal 'does' #italic 'this' #struckOut 'work' #normal)) startUpWithCaption: 'A Menu with Emphases'! ! !EncodedCharSet commentStamp: 'yo 10/19/2004 19:08' prior: 0! An abstract superclasss of the classes that represent encoded character sets. In the old implementation, the charsets had more important role. However, in the current implementation, the subclasses are used only for keeping the backward compatibility. The other confusion comes from the name of "Latin1" class. It used to mean the Latin-1 (ISO-8859-1) character set, but now it primarily means that the "Western European languages that are covered by the characters in Latin-1 character set. ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 10/14/2003 16:27'! charFromUnicode: unicode | table index | unicode < 256 ifTrue: [^ Character value: unicode]. table _ self ucsTable. index _ table indexOf: unicode. index = 0 ifTrue: [ ^ nil. ]. ^ MultiCharacter leadingChar: self leadingChar code: index - 1. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:57'! charsetAt: encoding ^ EncodedCharSets at: encoding + 1 ifAbsent: [EncodedCharSets at: 1]. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/1/2003 19:29'! digitValue: char "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and < 0 otherwise. This is used to parse literal numbers of radix 2-36." | value | value _ char charCode. value <= $9 asciiValue ifTrue: [^value - $0 asciiValue]. value >= $A asciiValue ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]]. ^ -1 ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 1/19/2005 11:33'! initialize " self initialize " self allSubclassesDo: [:each | each initialize]. EncodedCharSets _ Array new: 256. EncodedCharSets at: 0+1 put: Latin1Environment. EncodedCharSets at: 1+1 put: JISX0208. EncodedCharSets at: 2+1 put: GB2312. EncodedCharSets at: 3+1 put: KSX1001. EncodedCharSets at: 4+1 put: JISX0208. EncodedCharSets at: 5+1 put: JapaneseEnvironment. EncodedCharSets at: 6+1 put: SimplifiedChineseEnvironment. EncodedCharSets at: 7+1 put: KoreanEnvironment. EncodedCharSets at: 8+1 put: GB2312. "EncodedCharSets at: 9+1 put: UnicodeTraditionalChinese." "EncodedCharSets at: 10+1 put: UnicodeVietnamese." EncodedCharSets at: 12+1 put: KSX1001. EncodedCharSets at: 13+1 put: GreekEnvironment. EncodedCharSets at: 14+1 put: Latin2Environment. EncodedCharSets at: 256 put: Unicode. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 12/2/2004 16:13'! isCharset ^ true. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:32'! leadingChar self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 11/4/2002 14:43'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable latin1Table. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:55'! canBeGlobalVarInitial: char | leadingChar | leadingChar _ char leadingChar. leadingChar = 0 ifTrue: [^ self isUppercase: char]. ^ self isLetter: char. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 17:18'! canBeNonGlobalVarInitial: char | leadingChar | leadingChar _ char leadingChar. leadingChar = 0 ifTrue: [^ self isLowercase: char]. ^ self isLetter: char. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! isDigit: char "Answer whether the receiver is a digit." | value | value _ char asciiValue. ^ value >= 48 and: [value <= 57]. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! isLetter: char "Answer whether the receiver is a letter." | value | value _ char asciiValue. ^ (8r141 <= value and: [value <= 8r172]) or: [8r101 <= value and: [value <= 8r132]]. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:40'! isLowercase: char "Answer whether the receiver is a lowercase letter. (The old implementation answered whether the receiver is not an uppercase letter.)" | value | value _ char asciiValue. ^ 8r141 <= value and: [value <= 8r172]. ! ! !EncodedCharSet class methodsFor: 'character classification' stamp: 'yo 8/5/2003 16:44'! isUppercase: char "Answer whether the receiver is an uppercase letter. (The old implementation answered whether the receiver is not a lowercase letter.)" | value | value _ char asciiValue. ^ 8r101 <= value and: [value <= 8r132]. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'! isBreakableAt: index in: text self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 9/4/2002 22:51'! printingDirection self subclassResponsibility. ! ! !Encoder methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 18:46'! nTemps: n literals: lits class: cl "Decompile." supered _ false. class _ cl. nTemps _ n. literalStream _ ReadStream on: lits. literalStream position: lits size. sourceRanges _ Dictionary new: 32. globalSourceRanges _ OrderedCollection new: 32. ! ! !Encoder methodsFor: 'initialize-release' stamp: 'ajh 7/21/2003 00:53'! temps: tempVars literals: lits class: cl "Decompile." supered _ false. class _ cl. nTemps _ tempVars size. tempVars do: [:node | scopeTable at: node name put: node]. literalStream _ ReadStream on: lits. literalStream position: lits size. sourceRanges _ Dictionary new: 32. globalSourceRanges _ OrderedCollection new: 32. ! ! !Encoder methodsFor: 'encoding' stamp: 'yo 11/11/2002 10:22'! encodeVariable: name sourceRange: range ifUnknown: action | varNode | varNode _ scopeTable at: name ifAbsent: [(self lookupInPools: name ifFound: [:assoc | varNode _ self global: assoc name: name]) ifTrue: [varNode] ifFalse: [action value]]. range ifNotNil: [ name first canBeGlobalVarInitial ifTrue: [globalSourceRanges addLast: { name. range. false }]. ]. (varNode isTemp and: [varNode scope < 0]) ifTrue: [ OutOfScopeNotification signal ifFalse: [ ^self notify: 'out of scope']. ]. ^ varNode! ! !Encoder methodsFor: 'private' stamp: 'ar 8/14/2001 23:12'! global: ref name: name ^self name: name key: ref class: LiteralVariableNode type: LdLitIndType set: litIndSet! ! !Encoder methodsFor: 'private' stamp: 'ar 5/17/2003 14:16'! lookupInPools: varName ifFound: assocBlock Symbol hasInterned: varName ifTrue:[:sym| (class bindingOf: sym) ifNotNilDo:[:assoc| assocBlock value: assoc. ^true]. (Preferences valueOfFlag: #lenientScopeForGlobals) "**Temporary**" ifTrue: [^ Smalltalk lenientScopeHas: sym ifTrue: assocBlock] ifFalse: [^ false]]. (class bindingOf: varName) ifNotNilDo:[:assoc| assocBlock value: assoc. ^true]. ^false! ! !Encoder methodsFor: 'private' stamp: 'yo 11/11/2002 10:23'! possibleVariablesFor: proposedVariable | results | results _ proposedVariable correctAgainstDictionary: scopeTable continuedFrom: nil. proposedVariable first canBeGlobalVarInitial ifTrue: [ results _ class possibleVariablesFor: proposedVariable continuedFrom: results ]. ^ proposedVariable correctAgainst: nil continuedFrom: results. ! ! !Envelope class methodsFor: 'instance creation' stamp: 'tpr 9/13/2004 12:00'! example "Envelope example" | p | p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0. ^ (self points: p loopStart: 2 loopEnd: 4) sustainEnd: 1200. ! ! !Envelope class methodsFor: 'instance creation' stamp: 'tpr 9/13/2004 12:00'! exponentialDecay: multiplier "(Envelope exponentialDecay: 0.95) " | mSecsPerStep pList t v last | mSecsPerStep _ 10. ((multiplier > 0.0) and: [multiplier < 1.0]) ifFalse: [self error: 'multiplier must be greater than 0.0 and less than 1.0']. pList _ OrderedCollection new. pList add: 0@0.0. last _ 0.0. v _ 1.0. t _ 10. [v > 0.01] whileTrue: [ (v - last) abs > 0.02 ifTrue: [ "only record substatial changes" pList add: t@v. last _ v]. t _ t + mSecsPerStep. v _ v * multiplier]. pList add: (t + mSecsPerStep)@0.0. ^ self points: pList asArray loopStart: pList size loopEnd: pList size ! ! !EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:24'! addCurves "Add the polyLine corresponding to the currently selected envelope, and possibly all the others, too." | verts aLine | sound envelopes do: [:env | (showAllEnvelopes or: [env == envelope]) ifTrue: [verts _ env points collect: [:p | (self xFromMs: p x) @ (self yFromValue: p y)]. aLine _ EnvelopeLineMorph basicNew vertices: verts borderWidth: 1 borderColor: (self colorForEnvelope: env). env == envelope ifTrue: [aLine borderWidth: 2. line _ aLine] ifFalse: [aLine on: #mouseUp send: #clickOn:evt:from: to: self withValue: env. self addMorph: aLine]]]. self addMorph: line "add the active one last (in front)"! ! !EnvelopeEditorMorph methodsFor: 'construction' stamp: 'ar 3/17/2001 14:25'! addHandlesIn: frame | handle | handle := PolygonMorph vertices: (Array with: 0@0 with: 8@0 with: 4@8) color: Color orange borderWidth: 1 borderColor: Color black. handle addMorph: ((RectangleMorph newBounds: ((self handleOffset: handle)-(2@0) extent: 1@(graphArea height-2)) color: Color orange) borderWidth: 0). limitHandles _ Array with: handle with: handle veryDeepCopy with: handle veryDeepCopy. 1 to: limitHandles size do: [:i | handle _ limitHandles at: i. handle on: #mouseDown send: #limitHandleMove:event:from: to: self withValue: i. handle on: #mouseMove send: #limitHandleMove:event:from: to: self withValue: i. self addMorph: handle. handle position: ((self xFromMs: (envelope points at: (limits at: i)) x) @ (graphArea top)) - (self handleOffset: handle)]! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:23'! acceptGraphPoint: p at: index | ms val points whichLim linePoint other boundedP | boundedP := p adhereTo: graphArea bounds. ms := self msFromX: boundedP x. points := envelope points. ms := self constrain: ms adjacentTo: index in: points. (index = 1 or: [(whichLim := limits indexOf: index) > 0]) ifTrue: ["Limit points must not move laterally" ms := (points at: index) x]. val := self valueFromY: boundedP y. points at: index put: ms @ val. linePoint := (self xFromMs: ms) @ (self yFromValue: val). (whichLim notNil and: [whichLim between: 1 and: 2]) ifTrue: ["Loop start and loop end must be tied together" other := limits at: 3 - whichLim. " 1 <--> 2 " points at: other put: (points at: other) x @ val. line verticesAt: other put: (line vertices at: other) x @ linePoint y]. "Make sure envelope feels the change in points array..." envelope setPoints: points loopStart: limits first loopEnd: (limits second). ^linePoint! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'! clickOn: env evt: anEvent from: aLine self editEnvelope: env! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:27'! clickOnLine: arg1 evt: arg2 envelope: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self clickOn: arg1 evt: arg2 from: arg3! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:24'! deletePoint: ix "If the point is a limit point, return false, otherwise, delete the point at ix, and return true." (limits includes: ix) ifTrue: [^false]. 1 to: limits size do: [:i | "Decrease limit indices beyond the deletion" (limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) - 1]]. envelope setPoints: (envelope points copyReplaceFrom: ix to: ix with: Array new) loopStart: (limits first) loopEnd: (limits second). ^true! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'dgd 2/22/2003 14:24'! insertPointAfter: ix "If there is not enough roon (in x) then return false. Otherwise insert a point between ix and ix+1 and return true." | points pt | points := envelope points. (points at: ix + 1) x - (points at: ix) x < 20 ifTrue: [^false]. pt := ((points at: ix + 1) + (points at: ix)) // 2. 1 to: limits size do: [:i | "Increase limit indices beyond the insertion" (limits at: i) > ix ifTrue: [limits at: i put: (limits at: i) + 1]]. envelope setPoints: (points copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)) loopStart: (limits first) loopEnd: (limits second). ^true! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:24'! limitHandleMove: index event: evt from: handle "index is the handle index = 1, 2 or 3" | ix p ms x points limIx | ix _ limits at: index. "index of corresponding vertex" p _ evt cursorPoint adhereTo: graphArea bounds. ms _ self msFromX: p x + (self handleOffset: handle) x. "Constrain move to adjacent points on ALL envelopes" sound envelopes do: [:env | limIx _ env perform: (#(loopStartIndex loopEndIndex decayEndIndex) at: index). ms _ self constrain: ms adjacentTo: limIx in: env points]. "Update the handle, the vertex and the line being edited" x _ self xFromMs: ms. handle position: (x @ graphArea top) - (self handleOffset: handle). line verticesAt: ix put: x @ (line vertices at: ix) y. sound envelopes do: [:env | limIx _ env perform: (#(loopStartIndex loopEndIndex decayEndIndex) at: index). points _ env points. points at: limIx put: ms @ (points at: limIx) y. env setPoints: points loopStart: env loopStartIndex loopEnd: env loopEndIndex].! ! !EnvelopeEditorMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:27'! limitHandleMoveEvent: arg1 from: arg2 index: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self limitHandleMove: arg1 event: arg2 from: arg3! ! !EnvelopeEditorMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:19'! addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. menu addLine. envelope updateSelector = #ratio: ifTrue: [menu add: 'choose denominator...' translated action: #chooseDenominator:]. menu add: 'adjust scale...' translated action: #adjustScale:. SoundPlayer isReverbOn ifTrue: [menu add: 'turn reverb off' translated target: SoundPlayer selector: #stopReverb] ifFalse: [menu add: 'turn reverb on' translated target: SoundPlayer selector: #startReverb]. menu addLine. menu add: 'get sound from lib' translated action: #chooseSound:. menu add: 'put sound in lib' translated action: #saveSound:. menu add: 'read sound from disk...' translated action: #readFromDisk:. menu add: 'save sound on disk...' translated action: #saveToDisk:. menu add: 'save library on disk...' translated action: #saveLibToDisk:. ! ! !EnvelopeEditorMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 14:23'! adjustScale: evt | scaleString oldScale baseValue | oldScale := envelope scale. scaleString := FillInTheBlank request: 'Enter the new full-scale value...' initialAnswer: oldScale printString. scaleString isEmpty ifTrue: [^self]. envelope scale: (Number readFrom: scaleString) asFloat. baseValue := envelope updateSelector = #pitch: ifTrue: [0.5] ifFalse: [0.0]. envelope setPoints: (envelope points collect: [:p | p x @ ((p y - baseValue) * oldScale / envelope scale + baseValue min: 1.0 max: 0.0)]) loopStart: (limits first) loopEnd: (limits second). self buildView! ! !EnvelopeEditorMorph methodsFor: 'menu' stamp: 'sw 5/23/2001 14:26'! saveLibToDisk: evt "Save the library to disk" | newName f snd | newName _ FillInTheBlank request: 'Please confirm name for library...' initialAnswer: 'MySounds'. newName isEmpty ifTrue: [^ self]. f _ FileStream newFileNamed: newName , '.fml'. AbstractSound soundNames do: [:name | snd _ AbstractSound soundNamed: name. "snd isStorable" true ifTrue: [f nextChunkPut: 'AbstractSound soundNamed: ' , name , ' put: ' , snd storeString; cr; cr] ifFalse: [self inform: name , ' is not currently storable']]. f close! ! !EnvelopeLineMorph methodsFor: 'as yet unclassified' stamp: 'dgd 2/14/2003 20:17'! vertices: verts borderWidth: bw borderColor: bc super initialize. vertices _ verts. borderWidth _ bw. borderColor _ bc. closed _ false. arrows _ #none. self computeBounds! ! !EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:38'! dragVertex: ix event: evt fromHandle: handle | p | super dragVertex: ix event: evt fromHandle: handle. p _ owner acceptGraphPoint: evt cursorPoint at: ix. self verticesAt: ix put: p. ! ! !EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:31'! dropVertex: ix event: evt fromHandle: handle | oldVerts | oldVerts _ vertices. super dropVertex: ix event: evt fromHandle: handle. vertices = oldVerts ifFalse: [owner deletePoint: ix "deleted a vertex"]! ! !EnvelopeLineMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:39'! newVertex: ix event: evt fromHandle: handle "Install a new vertex if there is room." (owner insertPointAfter: ix) ifFalse: [^ self "not enough room"]. super newVertex: ix event: evt fromHandle: handle. self verticesAt: ix+1 put: (owner acceptGraphPoint: evt cursorPoint at: ix+1). ! ! !EnvelopeLineMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:16'! browseIndirectRefs "Smalltalk browseIndirectRefs" | cm lits browseList foundOne allClasses n | self flag: #mref. "no senders at the moment. also no Environments at the moment" browseList _ OrderedCollection new. allClasses _ OrderedCollection new. Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls]. 'Locating methods with indirect global references...' displayProgressAt: Sensor cursorPoint from: 0 to: allClasses size during: [:bar | n _ 0. allClasses do: [:cls | bar value: (n_ n+1). { cls. cls class } do: [:cl | cl selectors do: [:sel | cm _ cl compiledMethodAt: sel. lits _ cm literals. foundOne _ false. lits do: [:lit | lit isVariableBinding ifTrue: [(lit value == cl or: [(cl bindingOf: lit key) notNil]) ifFalse: [foundOne _ true]]]. foundOne ifTrue: [ browseList add: ( MethodReference new setStandardClass: cl methodSymbol: sel ) ]]]]]. self systemNavigation browseMessageList: browseList asSortedCollection name: 'Indirect Global References' autoSelect: nil! ! !Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:17'! rewriteIndirectRefs "Smalltalk rewriteIndirectRefs" "For all classes, identify all methods with references to globals outside their direct access path. For each of these, call another method to rewrite the source with proper references." | cm lits envtForVar envt foundOne allClasses n | envtForVar _ Dictionary new. "Dict of varName -> envt name" Smalltalk associationsDo: [:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500]) ifTrue: [envt associationsDo: [:a | envtForVar at: a key put: assn key]]]. "Allow compiler to compile refs to globals out of the direct reference path" Preferences enable: #lenientScopeForGlobals. allClasses _ OrderedCollection new. Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls]. 'Updating indirect global references in source code...' displayProgressAt: Sensor cursorPoint from: 0 to: allClasses size during: [:bar | n _ 0. allClasses do: [:cls | bar value: (n_ n+1). { cls. cls class } do: [:cl | cl selectors do: [:sel | cm _ cl compiledMethodAt: sel. lits _ cm literals. foundOne _ false. lits do: [:lit | lit isVariableBinding ifTrue: [(lit value == cl or: [(cl bindingOf: lit key) notNil]) ifFalse: [foundOne _ true]]]. foundOne ifTrue: [self rewriteSourceForSelector: sel inClass: cl using: envtForVar]]]. ]]. Preferences disable: #lenientScopeForGlobals. ! ! !Environment methodsFor: 'system conversion' stamp: 'ar 5/17/2003 14:17'! rewriteSourceForSelector: selector inClass: aClass using: envtForVar "Rewrite the source code for the method in question so that all global references out of the direct access path are converted to indirect global references. This is done by parsing the source with a lenient parser able to find variables in any environment. Then the parse tree is consulted for the source code ranges of each reference that needs to be rewritten and the pattern to which it should be rewritten. Note that assignments, which will take the form envt setValueOf: #GlobalName to: ... may generate spurious message due to agglutination of keywords with the value expression." | code methodNode edits varName eName envt | code _ aClass sourceCodeAt: selector. methodNode _ Compiler new parse: code in: aClass notifying: nil. edits _ OrderedCollection new. methodNode encoder globalSourceRanges do: [:tuple | "{ varName. srcRange. store }" (aClass bindingOf: (varName _ tuple first asSymbol)) notNil ifFalse: ["This is a remote global. Add it as reference to be edited." edits addLast: { varName. tuple at: 2. tuple at: 3 }]]. "Sort the edits by source position." edits _ edits asSortedCollection: [:a :b | a second first < b second first]. edits reverseDo: [:edit | varName _ edit first. (eName _ envtForVar at: varName ifAbsent: [nil]) ifNotNil: ["If varName is not already exported, define an export method" envt _ self at: eName. (envt class includesSelector: varName) ifFalse: [envt class compile: (self exportMethodFor: varName) classified: 'exports']. "Replace each access out of scope with a proper remote reference" code _ code copyReplaceFrom: edit second first to: edit second last with: eName , ' ' , varName]]. aClass compile: code classified: (aClass organization categoryOfElement: selector)! ! !Environment methodsFor: 'system conversion' stamp: 'ar 8/16/2001 13:25'! tallyIndirectRefs "Smalltalk tallyIndirectRefs" "For all classes, tally the number of references to globals outside their inherited environment. Then determine the 'closest' environment that resolves most of them. If the closest environment is different from the one in whick the class currently resides, then enter the class name with the tallies of its references to all other environments. Return a triplet: A dictionary of all classes for which this is so, with those tallies, A dictionary giving the classes that would be happier in each of the other categories, A list of the variable names sorted by number of occurrences." | tallies refs cm lits envtForVar envt envtRefs allRefs newCategories cat allClasses n | envtForVar _ Dictionary new. "Dict of varName -> envt name" allRefs _ Bag new. Smalltalk associationsDo: [:assn | (((envt _ assn value) isKindOf: Environment) and: [envt size < 500]) ifTrue: [envt associationsDo: [:a | envtForVar at: a key put: assn key]]]. tallies _ Dictionary new. allClasses _ OrderedCollection new. Smalltalk allClassesAnywhereDo: [:cls | allClasses addLast: cls]. 'Scanning methods with indirect global references...' displayProgressAt: Sensor cursorPoint from: 0 to: allClasses size during: [:bar | n _ 0. allClasses do: [:cls | bar value: (n_ n+1). refs _ Set new. { cls. cls class } do: [:cl | cl selectors do: [:sel | cm _ cl compiledMethodAt: sel. lits _ cm literals. lits do: [:lit | lit isVariableBinding ifTrue: [(lit value == cl or: [cls canFindWithoutEnvironment: lit key]) ifFalse: [refs add: lit key]]]]]. envtRefs _ Bag new. refs asSet do: [:varName | envtRefs add: (envtForVar at: varName) withOccurrences: (refs occurrencesOf: varName). (envtRefs sortedCounts isEmpty or: [envtRefs sortedCounts first value == (Smalltalk keyAtValue: cls environment)]) ifFalse: [allRefs add: varName withOccurrences: (refs occurrencesOf: varName). tallies at: cls name put: envtRefs sortedCounts. Transcript cr; print: envtRefs sortedCounts; endEntry]]]]. newCategories _ Dictionary new. tallies associationsDo: [:assn | cat _ assn value first value. (newCategories includesKey: cat) ifFalse: [newCategories at: cat put: Array new]. newCategories at: cat put: ((newCategories at: cat) copyWith: assn key)]. ^ { tallies. newCategories. allRefs sortedCounts }! ! !Environment methodsFor: '*Compiler' stamp: 'ar 5/17/2003 14:08'! bindingOf: varName ^self associationAtOrAbove: varName ifAbsent:[nil]! ! !Environment class methodsFor: 'system conversion' stamp: 'sd 4/17/2003 21:32'! computePrerequisites "We say one environment is a prerequisite of another if classes defined in the other inherit from classes in the first. Compute a dictionary with an entry for every non-kernel environment. That entry is another dictionary giving the names of any prerequisite environments and the list of classes that require it." "Environment computePrerequisites." "<-- inspect this" | bigCats bigCat preReqs supCat dict kernelCategories | bigCats _ IdentityDictionary new. kernelCategories _ Environment new kernelCategories. self flag: #NotSureOfTheSmalltalkReference. "sd" Smalltalk allClasses do: [:cl | bigCat _ (cl category asString copyUpTo: '-' first) asSymbol. (kernelCategories includes: bigCat) ifTrue: [bigCat _ #Kernel]. bigCats at: cl name put: bigCat]. preReqs _ IdentityDictionary new. self flag: #NotSureAboutTheSmalltalkReferenceHere. "sd" Smalltalk allClasses do: [:cl | cl superclass ifNotNil: [bigCat _ bigCats at: cl name. supCat _ bigCats at: cl superclass name. bigCat ~~ supCat ifTrue: [dict _ preReqs at: bigCat ifAbsent: [preReqs at: bigCat put: IdentityDictionary new]. dict at: supCat put: ((dict at: supCat ifAbsent: [Array new]) copyWith: cl name)]]]. ^ preReqs! ! !Environment class methodsFor: 'system conversion' stamp: 'ajh 9/13/2002 23:01'! reorganizeEverything "Undertake a grand reorganization. Environment reorganizeEverything. " | bigCat envt pool s | "First check for clashes between environment names and existing globals..." SystemOrganization categories do: [:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol. (Smalltalk kernelCategories includes: bigCat) ifFalse: [(Smalltalk includesKey: bigCat) ifTrue: [^ self error: bigCat , ' cannot be used to name both a package and a class or other global variable. No reorganization will be attempted.']]]. (self confirm: 'Your image is about to be partitioned into environments. Many things may not work after this, so you should be working in a throw-away copy of your working image. Are you really ready to procede? (choose ''no'' to stop here safely)') ifFalse: [^ self inform: 'No changes were made']. ChangeSet newChanges: (ChangeSet basicNewNamed: 'Reorganization'). "Recreate the Smalltalk dictionary as the top-level Environment." Smalltalk at: #Smalltalk put: (SmalltalkEnvironment newFrom: Smalltalk). Smalltalk setName: #Smalltalk inOuterEnvt: nil. "Don't hang onto old copy of Smalltalk ." Smalltalk recreateSpecialObjectsArray. Smalltalk allClassesDo: [:c | c environment: nil. "Flush any old values"]. "Run through all categories making up new sub-environments" SystemOrganization categories do: [:cat | bigCat _ (cat asString copyUpTo: '-' first) asSymbol. (Smalltalk kernelCategories includes: bigCat) ifFalse: ["Not a kernel category ..." envt _ Smalltalk at: bigCat ifAbsent: ["... make up a new environment if necessary ..." Smalltalk makeSubEnvironmentNamed: bigCat]. "... and install the member classes in that category" envt transferBindingsNamedIn: (SystemOrganization listAtCategoryNamed: cat) from: Smalltalk]. ]. "Move all shared pools that are only referred to in sub environments" Smalltalk associationsDo: [:assn | ((pool _ assn value) isMemberOf: Dictionary) ifTrue: [s _ IdentitySet new. Smalltalk allClassesAnywhereDo: [:c | c sharedPools do: [:p | p == pool ifTrue: [s add: c environment]]]. (s size = 1 and: [(envt _ s someElement) ~~ Smalltalk]) ifTrue: [envt declare: assn key from: Smalltalk]]]. Smalltalk rewriteIndirectRefs. ChangeSet newChanges: (ChangeSet basicNewNamed: 'PostReorganization'). ChangeSorter initialize. Preferences enable: #browserShowsPackagePane. ! ! !EqualityTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! resultFor: runs "Test that equality is the same over runs and answer the result" 1 to: runs do: [:i | self prototype = self prototype ifFalse: [^ false]]. ^ true! ! !EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0! I provide a simple way to test the equality properties of any object.! !Error methodsFor: 'private' stamp: 'ajh 2/1/2003 00:54'! isResumable "Determine whether an exception is resumable." ^ false! ! !Error methodsFor: 'exceptionDescription' stamp: 'ajh 9/4/2002 19:24'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !EtoyLoginMorph methodsFor: 'actions' stamp: 'ar 9/24/2000 00:08'! doCancel self delete. cancelBlock ifNotNil:[cancelBlock value].! ! !EtoyLoginMorph methodsFor: 'actions' stamp: 'dgd 10/8/2003 18:58'! doOK | proposed | proposed _ theNameMorph contents string. proposed isEmpty ifTrue: [^self inform: 'Please enter your login name' translated]. proposed size > 24 ifTrue: [^self inform: 'Please make the name 24 characters or less' translated]. (Project isBadNameForStoring: proposed) ifTrue: [ ^self inform: 'Please remove any funny characters' translated ]. (actionBlock value: proposed) ifTrue:[self delete].! ! !EtoyLoginMorph methodsFor: 'building' stamp: 'gm 3/11/2003 21:51'! buttonColor ^ Color paleYellow darker! ]style[(11 4 23)f2b,f2,f1cred;! ! !EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:48'! buttonNamed: aString action: aSymbol color: aColor help: helpString | f col | f _ SimpleButtonMorph new target: self; label: aString font: self myFont; color: aColor; actionSelector: aSymbol; setBalloonText: helpString. col _ (self inAColumn: {f}) hResizing: #spaceFill. ^col! ! !EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:49'! cancelButton ^self buttonNamed: 'Cancel' action: #doCancel color: self buttonColor help: 'Cancel this login operation.'! ! !EtoyLoginMorph methodsFor: 'building' stamp: 'nk 7/12/2003 08:40'! myFont ^ Preferences standardEToysFont! ! !EtoyLoginMorph methodsFor: 'building' stamp: 'ar 9/23/2000 13:50'! okButton ^self buttonNamed: 'OK' action: #doOK color: self buttonColor help: 'Login into Squeak'! ! !EtoyLoginMorph methodsFor: 'initialization' stamp: 'gm 3/11/2003 21:53'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color paleYellow darker! ]style[(18 2 61 27)f2b,f2,f2c142040000,f2! ! !EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 8! ! !EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 16:01'! defaultColor "answer the default color/fill style for the receiver" | result | result _ GradientFillStyle ramp: {0.0 -> (Color r: 0.5 g: 0.5 b: 1.0). 1.0 -> (Color r: 0.8 g: 0.8 b: 1.0)}. result origin: self bounds origin. result direction: 0 @ self bounds height. ^ result! ]style[(12 2 54 3 7 4 6 3 17 8 3 10 5 11 3 11 3 11 3 3 3 10 5 11 3 11 3 11 3 5 6 9 4 17 6 12 1 3 4 19 6)f2b,f2,f2c147045000,f2,f2cblue;i,f2,f2cblue;i,f2,f2cmagenta;,f2,f2c197197121,f2,f2cmagenta;,f2,f2c197197121,f2,f2c197197121,f2,f2c197197121,f2,f2c197197121,f2,f2cmagenta;,f2,f2c197197121,f2,f2c197197121,f2,f2c197197121,f2,f2cblue;i,f2,f2cmagenta;,f2,f2cblue;i,f2,f2c197197121,f2,f2cmagenta;,f2,f2cblue;i! ! !EtoyLoginMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:28'! initialize "initialize the state of the receiver" super initialize. "" self vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 4; beSticky; useRoundedCorners; rebuild. ! ! !EtoyLoginMorph methodsFor: 'initialization' stamp: 'ar 9/23/2000 14:13'! openInWorld: aWorld super openInWorld: aWorld. aWorld primaryHand newKeyboardFocus: theNameMorph.! ! !EtoyLoginMorph methodsFor: 'initialize' stamp: 'ar 9/24/2000 00:09'! name: aString actionBlock: aBlock cancelBlock: altBlock theName _ aString. actionBlock _ aBlock. cancelBlock _ altBlock. theNameMorph contentsWrapped: theName. theNameMorph editor selectAll.! ! !EtoyLoginMorph methodsFor: 'initialize' stamp: 'ar 9/23/2000 23:52'! rebuild self removeAllMorphs. self addARow: { (StringMorph contents:'') lock }. self addARow: { (StringMorph contents: 'Please enter your Squeak login name' font: self myFont) lock. }. (self addARow: { (theNameMorph _ TextMorph new beAllFont: self myFont; crAction: (MessageSend receiver: self selector: #doOK); extent: 300@20; contentsWrapped: 'the old name'; setBalloonText: 'Enter your name and avoid the following characters: : < > | / \ ? * "' ). }) color: Color white; borderColor: Color black; borderWidth: 1. self addARow: { self okButton. self cancelButton. }. self addARow: { (StringMorph contents:'') lock }. ! ! !EtoyLoginMorph class methodsFor: 'instance creation' stamp: 'ar 8/23/2001 21:37'! loginAndDo: aBlock ifCanceled: cancelBlock "EtoyLoginMorph loginAndDo:[:n| true] ifCanceled:[]" | me | (me _ self new) name: 'your name' actionBlock: aBlock cancelBlock: cancelBlock; fullBounds; position: Display extent - me extent // 2; openInWorld. me position: me position + (0@40).! ! !EventHandler methodsFor: 'access'! messageList "Return a list of 'Class selector' for each message I can send. tk 9/13/97" | list | self flag: #mref. "is this still needed? I replaced the one use that I could spot with #methodRefList " list _ SortedCollection new. mouseDownRecipient ifNotNil: [list add: (mouseDownRecipient class whichClassIncludesSelector: mouseDownSelector) name , ' ' , mouseDownSelector]. mouseMoveRecipient ifNotNil: [list add: (mouseMoveRecipient class whichClassIncludesSelector: mouseMoveSelector) name , ' ' , mouseMoveSelector]. mouseStillDownRecipient ifNotNil: [list add: (mouseStillDownRecipient class whichClassIncludesSelector: mouseStillDownSelector) name , ' ' , mouseStillDownSelector]. mouseUpRecipient ifNotNil: [list add: (mouseUpRecipient class whichClassIncludesSelector: mouseUpSelector) name , ' ' , mouseUpSelector]. mouseEnterRecipient ifNotNil: [list add: (mouseEnterRecipient class whichClassIncludesSelector: mouseEnterSelector) name , ' ' , mouseEnterSelector]. mouseLeaveRecipient ifNotNil: [list add: (mouseLeaveRecipient class whichClassIncludesSelector: mouseLeaveSelector) name , ' ' , mouseLeaveSelector]. mouseEnterDraggingRecipient ifNotNil: [list add: (mouseEnterDraggingRecipient class whichClassIncludesSelector: mouseEnterDraggingSelector) name , ' ' , mouseEnterDraggingSelector]. mouseLeaveDraggingRecipient ifNotNil: [list add: (mouseLeaveDraggingRecipient class whichClassIncludesSelector: mouseLeaveDraggingSelector) name , ' ' , mouseLeaveDraggingSelector]. doubleClickRecipient ifNotNil: [list add: (doubleClickRecipient class whichClassIncludesSelector: doubleClickSelector) name , ' ' , doubleClickSelector]. keyStrokeRecipient ifNotNil: [list add: (keyStrokeRecipient class whichClassIncludesSelector: keyStrokeSelector) name , ' ' , keyStrokeSelector]. ^ list! ! !EventHandler methodsFor: 'access'! methodRefList "Return a MethodReference for each message I can send. tk 9/13/97, raa 5/29/01 " | list adder | list _ SortedCollection new. adder _ [:recip :sel | recip ifNotNil: [list add: (MethodReference new setStandardClass: (recip class whichClassIncludesSelector: sel) methodSymbol: sel)]]. adder value: mouseDownRecipient value: mouseDownSelector. adder value: mouseMoveRecipient value: mouseMoveSelector. adder value: mouseStillDownRecipient value: mouseStillDownSelector. adder value: mouseUpRecipient value: mouseUpSelector. adder value: mouseEnterRecipient value: mouseEnterSelector. adder value: mouseLeaveRecipient value: mouseLeaveSelector. adder value: mouseEnterDraggingRecipient value: mouseEnterDraggingSelector. adder value: mouseLeaveDraggingRecipient value: mouseLeaveDraggingSelector. adder value: doubleClickRecipient value: doubleClickSelector. adder value: keyStrokeRecipient value: keyStrokeSelector. ^ list! ! !EventHandler methodsFor: 'copying' stamp: 'nk 2/14/2004 18:24'! veryDeepInner: deepCopier "ALL fields are weakly copied!! Can't duplicate an object by duplicating a button that activates it. See DeepCopier." super veryDeepInner: deepCopier. "just keep old pointers to all fields" ! ]style[(25 108 10 78)f1b,f1,f1LDeepCopier Comment;,f1! ! !EventHandler methodsFor: 'events' stamp: 'jcg 9/21/2001 13:06'! doubleClickTimeout: event fromMorph: sourceMorph ^ self send: doubleClickTimeoutSelector to: doubleClickTimeoutRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events' stamp: 'ar 3/17/2001 14:34'! send: selector to: recipient withEvent: event fromMorph: sourceMorph | arity | recipient ifNil: [^ self]. arity _ selector numArgs. arity = 0 ifTrue: [^ recipient perform: selector]. arity = 1 ifTrue: [^ recipient perform: selector with: event]. arity = 2 ifTrue: [^ recipient perform: selector with: event with: sourceMorph]. arity = 3 ifTrue: [^ recipient perform: selector with: valueParameter with: event with: sourceMorph]. self error: 'Event handling selectors must be Symbols and take 0-3 arguments'! ! !EventHandler methodsFor: 'fixups' stamp: 'sw 3/28/2001 14:22'! fixReversedValueMessages "ar 3/18/2001: Due to the change in the ordering of the value parameter old event handlers may have messages that need to be fixed up. Do this here." self replaceSendsIn: #( renameCharAction:sourceMorph:requestor: makeGetter:from:forPart: makeSetter:from:forPart: newMakeGetter:from:forPart: newMakeSetter:from:forPart: clickOnLine:evt:envelope: limitHandleMoveEvent:from:index: mouseUpEvent:linkMorph:formData: mouseUpEvent:linkMorph:browserAndUrl: mouseDownEvent:noteMorph:pitch: mouseMoveEvent:noteMorph:pitch: mouseUpEvent:noteMorph:pitch: dragVertex:fromHandle:vertIndex: dropVertex:fromHandle:vertIndex: newVertex:fromHandle:afterVert: prefMenu:rcvr:pref: event:arrow:upDown: newMakeGetter:from:forMethodInterface:) with: #( renameCharAction:event:sourceMorph: makeGetter:event:from: makeSetter:event:from: newMakeGetter:event:from: newMakeSetter:event:from: clickOn:evt:from: limitHandleMove:event:from: mouseUpFormData:event:linkMorph: mouseUpBrowserAndUrl:event:linkMorph: mouseDownPitch:event:noteMorph: mouseMovePitch:event:noteMorph: mouseUpPitch:event:noteMorph: dragVertex:event:fromHandle: dropVertex:event:fromHandle: newVertex:event:fromHandle: prefMenu:event:rcvr: upDown:event:arrow: makeUniversalTilesGetter:event:from:). "sw 3/28/2001 extended Andreas's original lists by one item"! ! !EventHandler methodsFor: 'fixups' stamp: 'ar 3/18/2001 17:18'! replaceSendsIn: array1 with: array2 "Replace all the sends that occur in array1 with those in array2. Used for fixing old event handlers in files." | old index | 1 to: self class instSize do:[:i| old _ self instVarAt: i. index _ array1 identityIndexOf: old. index > 0 ifTrue:[self instVarAt: i put: (array2 at: index)]].! ! !EventHandler methodsFor: 'initialization' stamp: 'ar 3/17/2001 20:12'! adaptToWorld: aWorld "If any of my recipients refer to a world or a hand, make them now refer to the corresponding items in the new world. (instVarNamed: is slow, later use perform of two selectors.)" | value newValue | #(mouseDownRecipient mouseStillDownRecipient mouseUpRecipient mouseEnterRecipient mouseLeaveRecipient mouseEnterDraggingRecipient mouseLeaveDraggingRecipient clickRecipient doubleClickRecipient startDragRecipient keyStrokeRecipient valueParameter) do: [:aName | (value _ self instVarNamed: aName asString) ifNotNil:[ newValue _ value adaptedToWorld: aWorld. (newValue notNil and: [newValue ~~ value]) ifTrue: [self instVarNamed: aName asString put: newValue]]]! ! !EventHandler methodsFor: 'initialization' stamp: 'jcg 9/21/2001 12:57'! forgetDispatchesTo: aSelector "aSelector is no longer implemented by my corresponding Player, so don't call it any more" mouseDownSelector == aSelector ifTrue: [mouseDownRecipient _ mouseDownSelector _ nil]. mouseMoveSelector == aSelector ifTrue: [mouseMoveRecipient _ mouseMoveSelector _ nil]. mouseStillDownSelector == aSelector ifTrue: [mouseStillDownRecipient _ mouseStillDownSelector _ nil]. mouseUpSelector == aSelector ifTrue: [mouseUpRecipient _ mouseUpSelector _ nil]. mouseEnterSelector == aSelector ifTrue: [mouseEnterRecipient _ mouseEnterSelector _ nil]. mouseLeaveSelector == aSelector ifTrue: [mouseLeaveRecipient _ mouseLeaveSelector _ nil]. mouseEnterDraggingSelector == aSelector ifTrue: [mouseEnterDraggingRecipient _ mouseEnterDraggingSelector _ nil]. mouseLeaveDraggingSelector == aSelector ifTrue: [mouseLeaveDraggingRecipient _ mouseLeaveDraggingSelector _ nil]. clickSelector == aSelector ifTrue: [clickRecipient _ clickSelector _ nil]. doubleClickSelector == aSelector ifTrue: [doubleClickRecipient _ doubleClickSelector _ nil]. doubleClickTimeoutSelector == aSelector ifTrue: [doubleClickTimeoutRecipient _ doubleClickTimeoutSelector _ nil]. keyStrokeSelector == aSelector ifTrue: [keyStrokeRecipient _ keyStrokeSelector _ nil].! ! !EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:16'! on: eventName send: selector to: recipient eventName == #mouseDown ifTrue: [mouseDownRecipient _ recipient. mouseDownSelector _ selector. ^ self]. eventName == #mouseMove ifTrue: [mouseMoveRecipient _ recipient. mouseMoveSelector _ selector. ^ self]. eventName == #mouseStillDown ifTrue: [mouseStillDownRecipient _ recipient. mouseStillDownSelector _ selector. ^ self]. eventName == #mouseUp ifTrue: [mouseUpRecipient _ recipient. mouseUpSelector _ selector. ^ self]. eventName == #mouseEnter ifTrue: [mouseEnterRecipient _ recipient. mouseEnterSelector _ selector. ^ self]. eventName == #mouseLeave ifTrue: [mouseLeaveRecipient _ recipient. mouseLeaveSelector _ selector. ^ self]. eventName == #mouseEnterDragging ifTrue: [mouseEnterDraggingRecipient _ recipient. mouseEnterDraggingSelector _ selector. ^ self]. eventName == #mouseLeaveDragging ifTrue: [mouseLeaveDraggingRecipient _ recipient. mouseLeaveDraggingSelector _ selector. ^ self]. eventName == #click ifTrue: [clickRecipient _ recipient. clickSelector _ selector. ^ self]. eventName == #doubleClick ifTrue: [doubleClickRecipient _ recipient. doubleClickSelector _ selector. ^ self]. eventName == #doubleClickTimeout ifTrue: [doubleClickTimeoutRecipient _ recipient. doubleClickTimeoutSelector _ selector. ^ self]. eventName == #startDrag ifTrue: [startDragRecipient _ recipient. startDragSelector _ selector. ^ self]. eventName == #keyStroke ifTrue: [keyStrokeRecipient _ recipient. keyStrokeSelector _ selector. ^ self]. eventName == #gesture ifTrue: [ ^self onGestureSend: selector to: recipient ]. self error: 'Event name, ' , eventName , ' is not recognizable.' ! ! !EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59'! onGestureSend: selector to: recipient! ! !EventHandler methodsFor: 'printing' stamp: 'dgd 2/22/2003 18:40'! printOn: aStream | aVal recipients | super printOn: aStream. #('mouseDownSelector' 'mouseStillDownSelector' 'mouseUpSelector' 'mouseEnterSelector' 'mouseLeaveSelector' 'mouseEnterDraggingSelector' 'mouseLeaveDraggingSelector' 'doubleClickSelector' 'keyStrokeSelector') do: [:aName | (aVal := self instVarNamed: aName) notNil ifTrue: [aStream nextPutAll: '; ' , aName , '=' , aVal]]. (recipients := self allRecipients) notEmpty ifTrue: [aStream nextPutAll: ' recipients: '. recipients printOn: aStream]! ! !EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:57'! handlesGestureStart: evt "Does the associated morph want to handle gestures?" ^false! ! !EventHandler methodsFor: 'testing' stamp: 'nk 2/15/2004 08:13'! handlesMouseDown: evt mouseDownRecipient ifNotNil: [^ true]. mouseStillDownRecipient ifNotNil: [^ true]. mouseUpRecipient ifNotNil: [^ true]. (self handlesClickOrDrag: evt) ifTrue:[^true]. ^self handlesGestureStart: evt! ! !EventManager methodsFor: 'copying' stamp: 'reThink 3/3/2001 10:22'! copy | answer | answer := super copy. answer release. ^answer! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:37'! actionMap ^actionMap == nil ifTrue: [self createActionMap] ifFalse: [actionMap]! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! changedEventSelector ^#changed:! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:39'! releaseActionMap actionMap := nil! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! updateEventSelector ^#update:! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:38'! updateableActionMap actionMap == nil ifTrue: [actionMap := self createActionMap]. ^actionMap! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! addDependent: anObject "Make the given object one of the receiver's dependents." self when: self changedEventSelector send: self updateEventSelector to: anObject. ^anObject! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! breakDependents "Remove all of the receiver's dependents." self removeActionsForEvent: self changedEventSelector! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:18'! dependents ^(self actionSequenceForEvent: self changedEventSelector) asSet collect: [:each | each receiver]! ! !EventManager methodsFor: 'dependents access' stamp: 'reThink 3/3/2001 10:07'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." self removeActionsWithReceiver: anObject forEvent: self changedEventSelector. ^ anObject! ! !EventManager methodsFor: 'updating' stamp: 'reThink 3/3/2001 10:20'! changed: aParameter "Receiver changed. The change is denoted by the argument aParameter. Usually the argument is a Symbol that is part of the dependent's change protocol. Inform all of the dependents." self triggerEvent: self changedEventSelector with: aParameter! ! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/18/2001 14:42'! actionMapFor: anObject ^self actionMaps at: anObject ifAbsent: [self createActionMap]! ! !EventManager class methodsFor: 'accessing' stamp: 'rww 10/2/2001 07:20'! actionMaps ActionMaps == nil ifTrue: [ActionMaps := WeakIdentityKeyDictionary new]. ^ActionMaps! ! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/25/2001 08:52'! updateableActionMapFor: anObject ^self actionMaps at: anObject ifAbsentPut: [self createActionMap]! ! !EventManager class methodsFor: 'releasing' stamp: 'reThink 2/18/2001 15:34'! releaseActionMapFor: anObject self actionMaps removeKey: anObject ifAbsent: []! ! !EventManager class methodsFor: 'initialize-release' stamp: 'rw 2/10/2002 13:09'! flushEvents "Object flushEvents" | msgSet | self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[ "make sure we don't modify evtDict while enumerating" evtDict keys do:[:evtName| msgSet _ evtDict at: evtName ifAbsent:[nil]. (msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]]. EventManager actionMaps finalizeValues. ! ! !EventManagerTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! addArg1: arg1 addArg2: arg2 eventListener add: arg1; add: arg2! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getFalse ^false! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getFalse: anArg ^false! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue ^true! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue: anArg ^true! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:20'! heardEvent succeeded := true! ! !EventManagerTest methodsFor: 'running' stamp: 'JWS 9/7/2000 17:19'! setUp super setUp. eventSource := EventManager new. eventListener := Bag new. succeeded := false! ! !EventManagerTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! tearDown eventSource releaseActionMap. eventSource := nil. eventListener := nil. super tearDown. ! ! !EventManagerTest methodsFor: 'running-copying' stamp: 'SqR 11/12/2000 19:38'! testCopy "Ensure that the actionMap is zapped when you make a copy of anEventManager" eventSource when: #blah send: #yourself to: eventListener. self assert: eventSource actionMap keys isEmpty not. self assert: eventSource copy actionMap keys isEmpty! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! testMultipleValueSuppliers eventSource when: #needsValue send: #getFalse to: self. eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:21'! testMultipleValueSuppliersEventHasArguments eventSource when: #needsValue: send: #getFalse: to: self. eventSource when: #needsValue: send: #getTrue: to: self. succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! testNoValueSupplier succeeded := eventSource triggerEvent: #needsValue ifNotHandled: [true]. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! testNoValueSupplierHasArguments succeeded := eventSource triggerEvent: #needsValue: with: 'nelja' ifNotHandled: [true]. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'jws 11/28/2000 15:52'! testSingleValueSupplier eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! testNoArgumentEvent eventSource when: #anEvent send: #heardEvent to: self. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! testOneArgumentEvent eventSource when: #anEvent: send: #add: to: eventListener. eventSource triggerEvent: #anEvent: with: 9. self should: [eventListener includes: 9]! ! !EventManagerTest methodsFor: 'running-dependent action' stamp: 'JWS 9/7/2000 17:20'! testTwoArgumentEvent eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self. eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! !EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:20'! testNoArgumentEventDependentSuppliedArgument eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'. eventSource triggerEvent: #anEvent. self should: [eventListener includes: 'boundValue']! ! !EventManagerTest methodsFor: 'running-dependent action supplied arguments' stamp: 'JWS 9/7/2000 17:21'! testNoArgumentEventDependentSuppliedArguments eventSource when: #anEvent send: #addArg1:addArg2: to: self withArguments: #('hello' 'world'). eventSource triggerEvent: #anEvent. self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! testRemoveActionsForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self shouldnt: [eventSource hasActionForEvent: #anEvent]! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:01'! testRemoveActionsTwiceForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not.! ! !EventManagerTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:10'! testRemoveActionsWithReceiver | action | eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsWithReceiver: self. action := eventSource actionForEvent: #anEvent. self assert: (action respondsTo: #receiver). self assert: ((action receiver == self) not)! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithManyListeners | value newListener | newListener := 'busybody'. eventSource when: #needsValue send: #yourself to: eventListener. eventSource when: #needsValue send: #yourself to: newListener. value := eventSource triggerEvent: #needsValue. self should: [value == newListener]! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithNoListeners | value | value := eventSource triggerEvent: #needsValue. self should: [value == nil]! ! !EventManagerTest methodsFor: 'running-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithOneListener | value | eventSource when: #needsValue send: #yourself to: eventListener. value := eventSource triggerEvent: #needsValue. self should: [value == eventListener]! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'yo 2/11/2005 09:59'! button "Make a simple button interface for replay only" | butnCaption erm | butnCaption _ FillInTheBlank request: 'Caption for this butn?' translated initialAnswer: 'play' translated. butnCaption isEmpty ifTrue: [^ self]. erm _ (EventRecorderMorph basicNew caption: butnCaption voiceRecorder: voiceRecorder copy tape: tape) initialize. self world primaryHand attachMorph: erm! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 2/22/2003 19:01'! condense "Shorten the tape by deleting mouseMove events that can just as well be interpolated later at playback time." "e1, e2, and e3 are three consecutive events on the tape. t1, t2, and t3 are the associated time steps for each of them." | e1 e2 t1 t2 e3 t3 | tape := Array streamContents: [:tStream | e1 := e2 := e3 := nil. t1 := t2 := t3 := nil. 1 to: tape size do: [:i | e1 := e2. t1 := t2. e2 := e3. t2 := t3. e3 := tape at: i. t3 := e3 timeStamp. ((e1 notNil and: [e2 type == #mouseMove & (e1 type == #mouseMove or: [e3 type == #mouseMove])]) and: ["Middle point within 3 pixels of mean of outer two" e2 position onLineFrom: e1 position to: e3 position within: 2.5]) ifTrue: ["Delete middle mouse move event. Absorb its time into e3" e2 := e1. t2 := t1] ifFalse: [e1 ifNotNil: [tStream nextPut: (e1 copy setTimeStamp: t1)]]]. e2 ifNotNil: [tStream nextPut: (e2 copy setTimeStamp: t2)]. e3 ifNotNil: [tStream nextPut: (e3 copy setTimeStamp: t3)]]! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:42'! play self isInWorld ifFalse: [^ self]. self stop. tape ifNil: [^ self]. tapeStream _ ReadStream on: tape. self resumePlayIn: self world. self setStatusLight: #nowPlaying. ! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:42'! record self isInWorld ifFalse: [^ self]. self stop. self writeCheck. self addJournalFile. tapeStream _ WriteStream on: (Array new: 10000). self resumeRecordIn: self world. self setStatusLight: #nowRecording. ! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'RAA 6/14/2001 16:43'! setStatusLight: aSymbol aSymbol == #ready ifTrue: [ statusLight color: Color green. tape ifNil: [ statusLight setBalloonText: 'Ready to record'. ] ifNotNil: [ statusLight setBalloonText: 'Ready to record or play'. ]. ^self ]. aSymbol == #nowRecording ifTrue: [ statusLight color: Color red; setBalloonText: 'Recording is active'. ^self ]. aSymbol == #nowPlaying ifTrue: [ statusLight color: Color yellow; setBalloonText: 'Now playing'. ^self ]. ! ! !EventRecorderMorph methodsFor: 'commands' stamp: 'dgd 9/21/2003 17:54'! shrink "Shorten the tape by deleting mouseMove events that can just as well be interpolated later at playback time." | oldSize priorSize | self writeCheck. oldSize _ priorSize _ tape size. [self condense. tape size < priorSize] whileTrue: [priorSize _ tape size]. self inform: ('{1} events reduced to {2}' translated format:{oldSize. tape size}). voiceRecorder ifNotNil: [voiceRecorder suppressSilence]. saved _ false. ! ! !EventRecorderMorph methodsFor: 'event handling' stamp: 'nk 7/11/2003 07:37'! nextEventToPlay "Return the next event when it is time to be replayed. If it is not yet time, then return an interpolated mouseMove. Return nil if nothing has happened. Return an EOF event if there are no more events to be played." | nextEvent now nextTime lastP delta | (tapeStream isNil or:[tapeStream atEnd]) ifTrue:[^MorphicUnknownEvent new setType: #EOF argument: nil]. now _ Time millisecondClockValue. nextEvent _ tapeStream next. nextEvent isKeyboard ifTrue: [ nextEvent setPosition: self position ]. deltaTime ifNil:[deltaTime _ now - nextEvent timeStamp]. nextTime _ nextEvent timeStamp + deltaTime. now < time ifTrue:["clock rollover" time _ now. deltaTime _ nil. ^nil "continue it on next cycle"]. time _ now. (now >= nextTime) ifTrue:[ nextEvent _ nextEvent copy setTimeStamp: nextTime. nextEvent isMouse ifTrue:[lastEvent _ nextEvent] ifFalse:[lastEvent _ nil]. ^nextEvent]. tapeStream skip: -1. "Not time for the next event yet, but interpolate the mouse. This allows tapes to be compressed when velocity is fairly constant." lastEvent ifNil: [^ nil]. lastP _ lastEvent position. delta _ (nextEvent position - lastP) * (now - lastEvent timeStamp) // (nextTime - lastEvent timeStamp). delta = lastDelta ifTrue: [^ nil]. "No movement" lastDelta _ delta. ^MouseMoveEvent new setType: #mouseMove startPoint: lastEvent position endPoint: lastP + delta trail: #() buttons: lastEvent buttons hand: nil stamp: now.! ! !EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'dgd 2/21/2003 23:15'! checkTape "See if this tape was already converted to the new format" tape ifNil: [^self]. tape isEmpty ifTrue: [^self]. (tape first isKindOf: Association) ifTrue: [tape := self convertV0Tape: tape]! ! !EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'md 7/15/2004 17:22'! readTape ^ self readTape: (FillInTheBlank request: 'Tape to read' initialAnswer: 'tapeName.tape').! ! !EventRecorderMorph methodsFor: 'fileIn/Out' stamp: 'md 7/15/2004 17:23'! writeTape | args b | args := (b := self button: 'writeTape') isNil ifTrue: [#()] ifFalse: [b arguments]. (args notEmpty and: [args first notEmpty]) ifTrue: [args first. self writeTape: args first] ifFalse: [^self writeTape: (FillInTheBlank request: 'Tape to write' initialAnswer: 'tapeName.tape')].! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:52'! addButtons | r b | caption ifNotNil: ["Special setup for play-only interface" (r _ self makeARowForButtons) addMorphBack: (SimpleButtonMorph new target: self; label: caption; actionSelector: #play); addMorphBack: self makeASpacer; addMorphBack: self makeStatusLight; addMorphBack: self makeASpacer. ^ self addMorphBack: r ]. (r _ self makeARowForButtons) addMorphBack: (b _ self buttonFor: {#record. nil. 'Begin recording'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#stop. b width. 'Stop recording - you can also use the ESC key to stop it'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#play. b width. 'Play current recording'}). self addMorphBack: r. (r _ self makeARowForButtons) addMorphBack: (b _ self buttonFor: {#writeTape. nil. 'Save current recording on disk'}); addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#readTape. b width. 'Get a new recording from disk'}). self addMorphBack: r. (r _ self makeARowForButtons) addMorphBack: (b _ self buttonFor: {#shrink. nil. 'Make recording shorter by removing unneeded events'}); addMorphBack: self makeASpacer; addMorphBack: self makeStatusLight; addMorphBack: self makeASpacer; addMorphBack: (self buttonFor: {#button. b width. 'Make a simple button to play this recording'}). self addMorph: r. self setStatusLight: #ready.! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 8/30/2003 21:19'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'add voice controls' translated action: #addVoiceControls. aCustomMenu add: 'add journal file' translated action: #addJournalFile. ! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'yo 2/11/2005 09:56'! buttonFor: data | b | b _ SimpleButtonMorph new target: self; label: data first asString translated; actionSelector: data first. data second ifNotNil: [b width < data second ifTrue: [b width: data second]]. data third ifNotNil: [b setBalloonText: data third translated]. ^b! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ #raised! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color red! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:21'! initialize "initialize the state of the receiver" super initialize. "" saved _ true. self listDirection: #topToBottom; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 2; minCellSize: 4; addButtons! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:19'! makeARowForButtons ^AlignmentMorph newRow vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter; minCellSize: 4; color: Color blue! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:14'! makeASpacer ^AlignmentMorph newSpacer: Color transparent! ! !EventRecorderMorph methodsFor: 'initialization' stamp: 'RAA 6/14/2001 16:13'! makeStatusLight ^statusLight _ EllipseMorph new extent: 11 @ 11; color: Color green; borderWidth: 0! ! !EventRecorderMorph methodsFor: 'pause/resume' stamp: 'RAA 6/14/2001 16:50'! pauseIn: aWorld "Suspend playing or recording, either as part of a stop command, or as part of a project switch, after which it will be resumed." self setStatusLight: #ready. state = #play ifTrue: [state _ #suspendedPlay. playHand delete. aWorld removeHand: playHand. playHand _ nil]. state = #record ifTrue: [state _ #suspendedRecord. recHand removeEventListener: self. recHand _ nil]. voiceRecorder ifNotNil: [voiceRecorder pause. startSoundEvent ifNotNil: [startSoundEvent argument: voiceRecorder recordedSound. voiceRecorder clearRecordedSound. startSoundEvent _ nil]]. ! ! !EventRecorderMorph methodsFor: 'stepping and presenter' stamp: 'RAA 6/14/2001 16:43'! stop state = #record ifTrue: [tape _ tapeStream contents. saved _ false]. journalFile ifNotNil: [journalFile close]. self pauseIn: self world. tapeStream _ nil. state _ nil. self setStatusLight: #ready. recordMeter ifNotNil: [recordMeter width: 1]. self checkTape.! ! !EventRecorderMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 17:25'! initialize FileList registerFileReader: self! ! !EventRecorderMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:31'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'tape') | (suffix = '*') ifTrue: [ self services] ifFalse: [#()] ! ! !EventRecorderMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:31'! services ^{SimpleServiceEntry provider: self label: 'open for playback' selector: #openTapeFromFile:.} ! ! !EventRecorderMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !EventRecorderMorph class methodsFor: 'instance creation' stamp: 'los 2/26/2004 11:46'! openTapeFromFile: fullName "Open an eventRecorder tape for playback." (self new) readTape: fullName; openInWorld! ! !EventRecorderMorph class methodsFor: 'parts bin' stamp: 'sw 11/21/2001 16:06'! descriptionForPartsBin "Answer a description for use in a parts bin" ^ self partName: 'Event Recorder' categories: #(Presentation Tools) documentation: 'Lets you record and play back interactions'! ! !EventSensor methodsFor: 'accessing' stamp: 'nk 4/12/2004 19:36'! eventTicklerProcess "Answer my event tickler process, if any" ^EventTicklerProcess! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:48'! flushAllButDandDEvents | newQueue oldQueue | newQueue _ SharedQueue new. self eventQueue ifNil: [eventQueue := newQueue. ^self]. oldQueue _ self eventQueue. [oldQueue size > 0] whileTrue: [| item type | item _ oldQueue next. type _ item at: 1. type = EventTypeDragDropFiles ifTrue: [ newQueue nextPut: item]]. eventQueue := newQueue. ! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/7/2001 17:13'! flushEvents eventQueue ifNotNil:[eventQueue flush].! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:41'! peekButtons self fetchMoreEvents. ^mouseButtons! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:51'! peekEvent "Look ahead at the next event." eventQueue ifNil:[^nil]. self fetchMoreEvents. ^eventQueue peek! ! !EventSensor methodsFor: 'accessing' stamp: 'tpr 1/5/2005 17:34'! peekKeyboardEvent "Return the next keyboard char event from the receiver or nil if none available" ^eventQueue nextOrNilSuchThat: [:buf | buf first = EventTypeKeyboard and: [(buf fourth) = EventKeyChar]]! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/8/2001 21:45'! peekMousePt ^mousePosition! ! !EventSensor methodsFor: 'accessing' stamp: 'ar 2/6/2004 14:41'! peekPosition self fetchMoreEvents. ^mousePosition! ! !EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:21'! initialize "Initialize the receiver" mouseButtons := 0. mousePosition := 0 @ 0. keyboardBuffer := SharedQueue new. self setInterruptKey: (interruptKey ifNil: [$. asciiValue bitOr: 16r0800 ]). "cmd-." interruptSemaphore := (Smalltalk specialObjectsArray at: 31) ifNil: [Semaphore new]. self flushAllButDandDEvents. inputSemaphore := Semaphore new. hasInputSemaphore := false.! ! !EventSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 20:13'! shutDown super shutDown. EventTicklerProcess ifNotNil: [ EventTicklerProcess terminate. EventTicklerProcess _ nil. ]. inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore]. ! ! !EventSensor methodsFor: 'initialize' stamp: 'nk 6/21/2004 10:42'! startUp "Run the I/O process" self initialize. self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). super startUp. self installEventTickler. Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents]. "Attempt to discover whether the input semaphore is actually being signaled." hasInputSemaphore := false. inputSemaphore initSignals. ! ! !EventSensor methodsFor: 'mouse' stamp: 'ar 5/18/2003 18:27'! createMouseEvent "create and return a new mouse event from the current mouse position; this is useful for restarting normal event queue processing after manual polling" | buttons modifiers pos mapped eventBuffer | eventBuffer _ Array new: 8. buttons _ self primMouseButtons. pos _ self primMousePt. modifiers _ buttons bitShift: -3. buttons _ buttons bitAnd: 7. mapped _ self mapButtons: buttons modifiers: modifiers. eventBuffer at: 1 put: EventTypeMouse; at: 2 put: Time millisecondClockValue; at: 3 put: pos x; at: 4 put: pos y; at: 5 put: mapped; at: 6 put: modifiers. ^ eventBuffer! ! !EventSensor methodsFor: 'private' stamp: 'nk 4/12/2004 20:16'! eventTickler "Poll infrequently to make sure that the UI process is not been stuck. If it has been stuck, then spin the event loop so that I can detect the interrupt key." | delay | delay := Delay forMilliseconds: self class eventPollPeriod. self lastEventPoll. "ensure not nil." [| delta | [ delay wait. delta := Time millisecondClockValue - lastEventPoll. (delta < 0 or: [delta > self class eventPollPeriod]) ifTrue: ["force check on rollover" self fetchMoreEvents]] on: Error do: [:ex | ]. true ] whileTrue.! ! !EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:52'! flushNonKbdEvents eventQueue ifNil: [^ self]. eventQueue flushAllSuchThat: [:buf | (self isKbdEvent: buf) not] ! ! !EventSensor methodsFor: 'private' stamp: 'nk 6/21/2004 10:40'! installEventTickler "Initialize the interrupt watcher process. Terminate the old process if any." "Sensor installEventTickler" EventTicklerProcess ifNotNil: [EventTicklerProcess terminate]. EventTicklerProcess _ [self eventTickler] forkAt: Processor lowIOPriority. ! ! !EventSensor methodsFor: 'private' stamp: 'di 10/1/2001 20:51'! isKbdEvent: buf ^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! ! !EventSensor methodsFor: 'private' stamp: 'nk 3/18/2004 13:21'! lastEventPoll "Answer the last clock value at which fetchMoreEvents was called." ^lastEventPoll ifNil: [ lastEventPoll _ Time millisecondClockValue ]! ! !EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:42'! nextEventFromQueue "Return the next event from the receiver." eventQueue isEmpty ifTrue:[self fetchMoreEvents]. eventQueue isEmpty ifTrue:[^nil] ifFalse:[^eventQueue next]! ! !EventSensor methodsFor: 'private' stamp: 'nk 3/17/2004 07:09'! nextEventSynthesized "Return a synthesized event. This method is called if an event driven client wants to receive events but the primary user interface is not event-driven (e.g., the receiver does not have an event queue but only updates its state). This can, for instance, happen if a Morphic World is run in an MVC window. To simplify the clients work this method will always return all available keyboard events first, and then (repeatedly) the mouse events. Since mouse events come last, the client can assume that after one mouse event has been received there are no more to come. Note that it is impossible for EventSensor to determine if a mouse event has been issued before so the client must be aware of the possible problem of getting repeatedly the same mouse events. See HandMorph>>processEvents for an example on how to deal with this." | kbd array buttons pos modifiers mapped | "First check for keyboard" array _ Array new: 8. kbd _ self primKbdNext. kbd ifNotNil: ["simulate keyboard event" array at: 1 put: EventTypeKeyboard. "evt type" array at: 2 put: Time millisecondClockValue. "time stamp" array at: 3 put: (kbd bitAnd: 255). "char code" array at: 4 put: EventKeyChar. "key press/release" array at: 5 put: (kbd bitShift: -8). "modifier keys" ^ array]. "Then check for mouse" pos _ self primMousePt. buttons _ mouseButtons. modifiers _ buttons bitShift: -3. buttons _ buttons bitAnd: 7. mapped _ self mapButtons: buttons modifiers: modifiers. array at: 1 put: EventTypeMouse; at: 2 put: Time millisecondClockValue; at: 3 put: pos x; at: 4 put: pos y; at: 5 put: mapped; at: 6 put: modifiers. ^ array ! ! !EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:41'! primKbdNext "Allows for use of old Sensor protocol to get at the keyboard, as when running kbdTest or the InterpreterSimulator in Morphic" | evtBuf | self fetchMoreEvents. keyboardBuffer isEmpty ifFalse:[^ keyboardBuffer next]. eventQueue ifNotNil: [evtBuf _ eventQueue nextOrNilSuchThat: [:buf | self isKbdEvent: buf]. self flushNonKbdEvents]. ^ evtBuf ifNotNil: [evtBuf at: 3] ! ! !EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:41'! primKbdPeek "Allows for use of old Sensor protocol to get at the keyboard, as when running kbdTest or the InterpreterSimulator in Morphic" | char | self fetchMoreEvents. keyboardBuffer isEmpty ifFalse: [^ keyboardBuffer peek]. char _ nil. eventQueue ifNotNil: [eventQueue nextOrNilSuchThat: "NOTE: must not return out of this block, so loop to end" [:buf | (self isKbdEvent: buf) ifTrue: [char ifNil: [char _ buf at: 3]]. false "NOTE: block value must be false so Queue won't advance"]]. ^ char! ! !EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:42'! primMouseButtons self fetchMoreEvents. self flushNonKbdEvents. ^ mouseButtons! ! !EventSensor methodsFor: 'private' stamp: 'ar 2/6/2004 14:41'! primMousePt self fetchMoreEvents. self flushNonKbdEvents. ^ mousePosition! ! !EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/12/2004 20:01'! fetchMoreEvents "Fetch more events from the VM" | eventBuffer type | "Reset input semaphore so clients can wait for the next events after this one." inputSemaphore isSignaled ifTrue: [ hasInputSemaphore _ true. inputSemaphore initSignals ]. "Remember the last time that I checked for events." lastEventPoll := Time millisecondClockValue. eventBuffer := Array new: 8. [self primGetNextEvent: eventBuffer. type := eventBuffer at: 1. type = EventTypeNone] whileFalse: [self processEvent: eventBuffer]. ! ! !EventSensor methodsFor: 'private-I/O' stamp: 'nk 2/11/2002 12:18'! processEvent: evt "Process a single event. This method is run at high priority." | type | type _ evt at: 1. "Check if the event is a user interrupt" (type = EventTypeKeyboard and:[(evt at: 4) = 0 and:[ ((evt at: 3) bitOr: ((evt at: 5) bitShift: 8)) = interruptKey]]) ifTrue:["interrupt key is meta - not reported as event" ^interruptSemaphore signal]. "Store the event in the queue if there's any" type = EventTypeMouse ifTrue: [evt at: 5 put: (ButtonDecodeTable at: (evt at: 5) + 1)]. type = EventTypeKeyboard ifTrue: ["swap ctrl/alt keys" KeyDecodeTable at: { evt at: 3 . evt at: 5 } ifPresent: [:a | evt at: 3 put: a first; at: 5 put: a second]]. self queueEvent: evt. "Update state for InputSensor." EventTypeMouse = type ifTrue:[self processMouseEvent: evt]. EventTypeKeyboard = type ifTrue:[self processKeyboardEvent: evt]! ! !EventSensor methodsFor: 'private-I/O' stamp: 'nk 4/11/2001 18:28'! processKeyboardEvent: evt "process a keyboard event, updating InputSensor state" | charCode pressCode | "Never update keyboardBuffer if we have an eventQueue active" mouseButtons _ (mouseButtons bitAnd: 7) bitOr: ((evt at: 5) bitShift: 3). eventQueue ifNotNil:[^self]. charCode _ evt at: 3. charCode = nil ifTrue:[^self]. "extra characters not handled in MVC" pressCode _ evt at: 4. pressCode = EventKeyChar ifFalse:[^self]. "key down/up not handled in MVC" "mix in modifiers" charCode _ charCode bitOr: ((evt at: 5) bitShift: 8). keyboardBuffer nextPut: charCode.! ! !EventSensor commentStamp: 'nk 4/13/2004 11:18' prior: 0! EventSensor is a replacement for InputSensor based on a set of (optional) event primitives. An EventSensor updates its state when events are received so that all state based users of Sensor (e.g., Sensor keyboard, Sensor leftShiftDown, Sensor mouseButtons) will work exactly as before, by moving the current VM mechanisms into EventSensor itself. An optional input semaphore is part of the new design. For platforms that support true asynchronous event notification, the semaphore will be signaled to indicate pending events. On platforms that do not support asynchronous notifications about events, the UI will have to poll EventSensor periodically to read events from the VM. Instance variables: mouseButtons - mouse button state as replacement for primMouseButtons mousePosition - mouse position as replacement for primMousePt keyboardBuffer - keyboard input buffer interruptKey - currently defined interrupt key interruptSemaphore - the semaphore signaled when the interruptKey is detected eventQueue - an optional event queue for event driven applications inputSemaphore - the semaphore signaled by the VM if asynchronous event notification is supported lastEventPoll - the last millisecondClockValue at which we called fetchMoreEvents hasInputSemaphore - true if my inputSemaphore has actually been signaled at least once. Class variables: EventPollPeriod - the number of milliseconds to wait between polling for more events in the userInterruptHandler. EventTicklerProcess - the process that makes sure that events are polled for often enough (at least every EventPollPeriod milliseconds). Event format: The current event format is very simple. Each event is recorded into an 8 element array. All events must provide some SmallInteger ID (the first field in the event buffer) and a time stamp (the second field in the event buffer), so that the difference between the time stamp of an event and the current time can be reported. Currently, the following events are defined: Null event ============= The Null event is returned when the ST side asks for more events but no more events are available. Structure: [1] - event type 0 [2-8] - unused Mouse event structure ========================== Mouse events are generated when mouse input is detected. Structure: [1] - event type 1 [2] - time stamp [3] - mouse x position [4] - mouse y position [5] - button state; bitfield with the following entries: 1 - yellow (e.g., right) button 2 - blue (e.g., middle) button 4 - red (e.g., left) button [all other bits are currently undefined] [6] - modifier keys; bitfield with the following entries: 1 - shift key 2 - ctrl key 4 - (Mac specific) option key 8 - Cmd/Alt key [all other bits are currently undefined] [7] - reserved. [8] - reserved. Keyboard events ==================== Keyboard events are generated when keyboard input is detected. [1] - event type 2 [2] - time stamp [3] - character code For now the character code is in Mac Roman encoding. [4] - press state; integer with the following meaning 0 - character 1 - key press (down) 2 - key release (up) [5] - modifier keys (same as in mouse events) [6] - reserved. [7] - reserved. [8] - reserved. ! !EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'! eventPollPeriod ^EventPollPeriod ifNil: [ EventPollPeriod _ 500 ].! ! !EventSensor class methodsFor: 'class initialization' stamp: 'nk 4/12/2004 18:55'! eventPollPeriod: msec "Set the number of milliseconds between checking for events to msec." EventPollPeriod _ msec max: 10.! ! !EventSensorConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:26'! initialize "EventSensorConstants initialize" RedButtonBit := 4. BlueButtonBit := 2. YellowButtonBit := 1. ShiftKeyBit := 1. CtrlKeyBit := 2. OptionKeyBit := 4. CommandKeyBit := 8. "Types of events" EventTypeNone := 0. EventTypeMouse := 1. EventTypeKeyboard := 2. EventTypeDragDropFiles := 3. "Press codes for keyboard events" EventKeyChar := 0. EventKeyDown := 1. EventKeyUp := 2. ! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! addArg1: arg1 addArg2: arg2 eventListener add: arg1; add: arg2! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! getFalse ^false! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:37'! getFalse: anArg ^false! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! getTrue ^true! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! getTrue: anArg ^true! ! !EventTest methodsFor: 'private' stamp: 'jws 9/7/2000 16:38'! heardEvent succeeded := true! ! !EventTest methodsFor: 'running' stamp: 'jws 9/7/2000 16:37'! setUp super setUp. eventSource := Object new. eventListener := Bag new. succeeded := false! ! !EventTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! tearDown eventSource releaseActionMap. eventSource := nil. eventListener := nil. super tearDown. ! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! testMultipleValueSuppliers eventSource when: #needsValue send: #getFalse to: self. eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! testMultipleValueSuppliersEventHasArguments eventSource when: #needsValue: send: #getFalse: to: self. eventSource when: #needsValue: send: #getTrue: to: self. succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. self should: [succeeded]! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'rw 4/27/2002 09:12'! testMultipleValueSuppliersEventHasArgumentsWithGC eventSource when: #needsValue: send: #getFalse: to: self with: Object new. eventSource when: #needsValue: send: #getTrue: to: self with: Object new. Smalltalk garbageCollectMost. succeeded := eventSource triggerEvent: #needsValue: with: 'kolme'. self should: [succeeded = nil] ! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! testNoValueSupplier succeeded := eventSource triggerEvent: #needsValue ifNotHandled: [true]. self should: [succeeded]! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:41'! testNoValueSupplierHasArguments succeeded := eventSource triggerEvent: #needsValue: with: 'nelja' ifNotHandled: [true]. self should: [succeeded]! ! !EventTest methodsFor: 'running-broadcast query' stamp: 'jws 9/7/2000 16:42'! testSingleValueSupplier eventSource when: #needsValue send: #getTrue to: self. succeeded := eventSource triggerEvent: #needsValue. self should: [succeeded]! ! !EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! testNoArgumentEvent eventSource when: #anEvent send: #heardEvent to: self. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! testOneArgumentEvent eventSource when: #anEvent: send: #add: to: eventListener. eventSource triggerEvent: #anEvent: with: 9. self should: [eventListener includes: 9]! ! !EventTest methodsFor: 'running-dependent action' stamp: 'jws 9/7/2000 16:39'! testTwoArgumentEvent eventSource when: #anEvent:info: send: #addArg1:addArg2: to: self. eventSource triggerEvent: #anEvent:info: withArguments: #( 9 42 ). self should: [(eventListener includes: 9) and: [eventListener includes: 42]]! ! !EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:39'! testNoArgumentEventDependentSuppliedArgument eventSource when: #anEvent send: #add: to: eventListener with: 'boundValue'. eventSource triggerEvent: #anEvent. self should: [eventListener includes: 'boundValue']! ! !EventTest methodsFor: 'running-dependent action supplied arguments' stamp: 'jws 9/7/2000 16:40'! testNoArgumentEventDependentSuppliedArguments eventSource when: #anEvent send: #addArg1:addArg2: to: self withArguments: #('hello' 'world'). eventSource triggerEvent: #anEvent. self should: [(eventListener includes: 'hello') and: [eventListener includes: 'world']]! ! !EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:04'! testRemoveActionsForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self shouldnt: [eventSource hasActionForEvent: #anEvent]! ! !EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'! testRemoveActionsTwiceForEvent eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not. eventSource removeActionsForEvent: #anEvent. self assert: (eventSource hasActionForEvent: #anEvent) not.! ! !EventTest methodsFor: 'running-remove actions' stamp: 'SqR 2/19/2001 14:05'! testRemoveActionsWithReceiver | action | eventSource when: #anEvent send: #size to: eventListener; when: #anEvent send: #getTrue to: self; when: #anEvent: send: #fizzbin to: self. eventSource removeActionsWithReceiver: self. action := eventSource actionForEvent: #anEvent. self assert: (action respondsTo: #receiver). self assert: ((action receiver == self) not)! ! !EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! testReturnValueWithManyListeners | value newListener | newListener := 'busybody'. eventSource when: #needsValue send: #yourself to: eventListener. eventSource when: #needsValue send: #yourself to: newListener. value := eventSource triggerEvent: #needsValue. self should: [value == newListener]! ! !EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! testReturnValueWithNoListeners | value | value := eventSource triggerEvent: #needsValue. self should: [value == nil]! ! !EventTest methodsFor: 'running-dependent value' stamp: 'jws 9/7/2000 16:40'! testReturnValueWithOneListener | value | eventSource when: #needsValue send: #yourself to: eventListener. value := eventSource triggerEvent: #needsValue. self should: [value == eventListener]! ! !ExampleSetTest methodsFor: 'testing'! testAdd empty add: 5. self assert: (empty includes: 5) ! ! !ExampleSetTest methodsFor: 'testing'! testGrow empty addAll: (1 to: 100). self assert: empty size = 100 ! ! !ExampleSetTest methodsFor: 'testing'! testIllegal self should: [empty at: 5] raise: TestResult error. self should: [empty at: 5 put: #abc] raise: TestResult error ! ! !ExampleSetTest methodsFor: 'testing'! testIncludes self assert: (full includes: 5). self assert: (full includes: #abc) ! ! !ExampleSetTest methodsFor: 'testing'! testOccurrences self assert: (empty occurrencesOf: 0) = 0. self assert: (full occurrencesOf: 5) = 1. full add: 5. self assert: (full occurrencesOf: 5) = 1 ! ! !ExampleSetTest methodsFor: 'testing'! testRemove full remove: 5. self assert: (full includes: #abc). self deny: (full includes: 5) ! ! !ExampleSetTest methodsFor: 'running'! setUp empty := Set new. full := Set with: 5 with: #abc ! ! !Exception methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:23'! tag: t "This message is not specified in the ANSI protocol, but that looks like an oversight because #tag is specified, and the spec states that the signaler may store the tag value." tag := t! ! !Exception methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 14:54'! tag "Return an exception's tag value." ^tag == nil ifTrue: [self messageText] ifFalse: [tag]! ! !Exception methodsFor: '*Refactory-RBAddons' stamp: 'ajh 2/16/2003 17:37'! searchFrom: aContext " Set the context where the handler search will start. " signalContext := aContext contextTag! ! !Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:32'! isNested "Determine whether the current exception handler is within the scope of another handler for the same exception." ^ handlerContext nextHandlerContext canHandleSignal: self! ! !Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:13'! outer "Evaluate the enclosing exception action and return to here instead of signal if it resumes (see #resumeUnchecked:)." | prevOuterContext | self isResumable ifTrue: [ prevOuterContext _ outerContext. outerContext _ thisContext contextTag. ]. self pass. ! ! !Exception methodsFor: 'handling' stamp: 'ajh 2/1/2003 01:33'! pass "Yield control to the enclosing exception action for the receiver." handlerContext nextHandlerContext handleSignal: self! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/22/2003 23:04'! resignalAs: replacementException "Signal an alternative exception in place of the receiver." self resumeUnchecked: replacementException signal! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:09'! resume "Return from the message that signaled the receiver." self resume: nil! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/13/2002 15:14'! resume: resumptionValue "Return resumptionValue as the value of the signal message." self isResumable ifFalse: [IllegalResumeAttempt signal]. self resumeUnchecked: resumptionValue! ! !Exception methodsFor: 'handling' stamp: 'ajh 6/27/2003 22:30'! resumeUnchecked: resumptionValue "Return resumptionValue as the value of #signal, unless this was called after an #outer message, then return resumptionValue as the value of #outer." | ctxt | outerContext ifNil: [ signalContext return: resumptionValue ] ifNotNil: [ ctxt _ outerContext. outerContext _ ctxt tempAt: 1. "prevOuterContext in #outer" ctxt return: resumptionValue ]. ! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:36'! retry "Abort an exception handler and re-evaluate its protected block." handlerContext restart! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! retryUsing: alternativeBlock "Abort an exception handler and evaluate a new block in place of the handler's protected block." handlerContext restartWithNewReceiver: alternativeBlock ! ! !Exception methodsFor: 'handling' stamp: 'ajh 9/30/2001 15:33'! return "Return nil as the value of the block protected by the active exception handler." self return: nil! ! !Exception methodsFor: 'handling' stamp: 'ajh 1/29/2003 13:37'! return: returnValue "Return the argument as the value of the block protected by the active exception handler." handlerContext return: returnValue! ! !Exception methodsFor: 'printing' stamp: 'pnm 8/16/2000 14:53'! description "Return a textual description of the exception." | desc mt | desc := self class name asString. ^(mt := self messageText) == nil ifTrue: [desc] ifFalse: [desc, ': ', mt]! ! !Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! messageText "Return an exception's message text." ^messageText! ! !Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! printOn: stream stream nextPutAll: self description! ! !Exception methodsFor: 'printing' stamp: 'ajh 10/22/2001 14:24'! receiver ^ self signalerContext receiver! ! !Exception methodsFor: 'printing' stamp: 'ar 6/28/2003 00:13'! signalerContext "Find the first sender of signal(:)" ^ signalContext findContextSuchThat: [:ctxt | (ctxt receiver == self or: [ctxt receiver == self class]) not]! ! !Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33'! messageText: signalerText "Set an exception's message text." messageText := signalerText! ! !Exception methodsFor: 'signaling' stamp: 'ajh 2/1/2003 01:33'! signal "Ask ContextHandlers in the sender chain to handle this signal. The default is to execute and return my defaultAction." signalContext _ thisContext contextTag. ^ thisContext nextHandlerContext handleSignal: self! ! !Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 20:13'! signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." self messageText: signalerText. ^ self signal! ! !Exception methodsFor: 'priv handling' stamp: 'ajh 9/30/2001 15:33'! defaultAction "The default action taken if the exception is signaled." self subclassResponsibility! ! !Exception methodsFor: 'priv handling' stamp: 'ajh 2/1/2003 00:58'! isResumable "Determine whether an exception is resumable." ^ true! ! !Exception methodsFor: 'priv handling' stamp: 'ajh 1/29/2003 13:44'! privHandlerContext: aContextTag handlerContext _ aContextTag! ! !Exception methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 10:03'! sunitExitWith: aValue self return: aValue! ! !Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54'! signal "Signal the occurrence of an exceptional condition." ^ self new signal! ! !Exception class methodsFor: 'exceptionInstantiator' stamp: 'ajh 9/30/2001 21:54'! signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." ^ self new signal: signalerText! ! !Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 9/30/2001 15:33'! , anotherException "Create an exception set." ^ExceptionSet new add: self; add: anotherException; yourself! ! !Exception class methodsFor: 'exceptionSelector' stamp: 'ajh 8/5/2003 11:33'! handles: exception "Determine whether an exception handler will accept a signaled exception." ^ exception isKindOf: self! ! !Exception class methodsFor: 'Camp Smalltalk' stamp: 'jp 3/17/2003 10:04'! sunitSignalWith: aString ^self signal: aString! ! !ExceptionSet methodsFor: 'exceptionSelector' stamp: 'pnm 8/16/2000 15:15'! handles: anException "Determine whether an exception handler will accept a signaled exception." exceptions do: [:ex | (ex handles: anException) ifTrue: [^true]]. ^false! ! !ExceptionTester methodsFor: 'accessing' stamp: 'dtl 6/1/2004 21:53'! basicANSISignaledExceptionTestSelectors ^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:54'! basicTestSelectors ^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingElseString ^'Do something else.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingExceptionalString ^'Do something exceptional.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'! doSomethingString ^'Do something.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThingString ^'Do yet another thing.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:15'! iterationsBeforeTimeout ^ iterationsBeforeTimeout! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:16'! iterationsBeforeTimeout: anInteger iterationsBeforeTimeout := anInteger! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'! log log == nil ifTrue: [log := OrderedCollection new]. ^log! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:30'! suiteLog suiteLog == nil ifTrue: [suiteLog := OrderedCollection new]. ^suiteLog! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! testString ^'This is only a test.'! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:17'! clearLog log := nil! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:16'! contents ^( self log inject: (WriteStream on: (String new: 80)) into: [:result :item | result cr; nextPutAll: item; yourself] ) contents! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/7/1999 15:03'! log: aString self log add: aString! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'! logTest: aSelector self suiteLog add: aSelector! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/8/1999 09:38'! logTestResult: aString | index | index := self suiteLog size. self suiteLog at: index put: ((self suiteLog at: index), ' ', aString)! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'! doSomething self log: self doSomethingString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! doSomethingElse self log: self doSomethingElseString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:14'! doSomethingExceptional self log: self doSomethingExceptionalString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThing self log: self doYetAnotherThingString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithError MyTestError signal: self testString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithNotification MyTestNotification signal: self testString! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 11/14/1999 17:26'! doubleResumeTest [self doSomething. MyResumableTestError signal. self doSomethingElse. MyResumableTestError signal. self doYetAnotherThing] on: MyResumableTestError do: [:ex | ex resume].! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 13:43'! nonResumableFallOffTheEndHandler [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:07'! resumableFallOffTheEndHandler [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | self doSomethingExceptional]. self doYetAnotherThing! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 8/19/1999 01:39'! signalFromHandlerActionTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [self doYetAnotherThing. MyTestError signal]! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'! simpleEnsureTest [self doSomething. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'! simpleEnsureTestWithError [self doSomething. MyTestError signal. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'! simpleEnsureTestWithNotification [self doSomething. self methodWithNotification. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/9/1999 16:04'! simpleEnsureTestWithUparrow [self doSomething. true ifTrue: [^nil]. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleNoTimeoutTest [ self doSomething ] valueWithin: 1 day onTimeout: [ self doSomethingElse ]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleTimeoutTest | n | [1 to: 1000000 do: [ :i | n := i. self doSomething ] ] valueWithin: 50 milliSeconds onTimeout: [ self iterationsBeforeTimeout: n. self doSomethingElse ]! ! !ExceptionTester methodsFor: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleTimeoutWithZeroDurationTest [ self doSomething ] valueWithin: 0 seconds onTimeout: [ self doSomethingElse ]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/7/1999 14:28'! warningTest self log: 'About to signal warning.'. Warning signal: 'Ouch'. self log: 'Warning signal handled and resumed.'! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 11/14/1999 17:29'! doubleResumeTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:21'! nonResumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 02:39'! resumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 8/19/1999 01:51'! signalFromHandlerActionTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 09:47'! simpleEnsureTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/9/1999 17:44'! simpleEnsureTestWithErrorResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 10:13'! simpleEnsureTestWithNotificationResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'tfei 6/8/1999 18:55'! simpleEnsureTestWithUparrowResults ^OrderedCollection new add: self doSomethingString; " add: self doSomethingElseString;" add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:54'! simpleNoTimeoutTestResults ^OrderedCollection new add: self doSomethingString; yourself! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 17:44'! simpleTimeoutTestResults | things | things := OrderedCollection new: self iterationsBeforeTimeout. self iterationsBeforeTimeout timesRepeat: [ things add: self doSomethingString ]. things add: self doSomethingElseString. ^ things! ! !ExceptionTester methodsFor: 'results' stamp: 'brp 10/21/2004 16:52'! simpleTimeoutWithZeroDurationTestResults ^OrderedCollection new add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/13/1999 01:25'! runAllTests "ExceptionTester new runAllTests" self runBasicTests; runBasicANSISignaledExceptionTests! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'! runBasicANSISignaledExceptionTests self basicANSISignaledExceptionTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'! runBasicTests self basicTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !ExceptionTester methodsFor: 'testing' stamp: 'brp 10/21/2004 17:40'! runTest: aSelector | actualResult expectedResult | [ self logTest: aSelector; clearLog; perform: aSelector ] on: MyTestError do: [ :ex | self log: 'Unhandled Exception'. ex return: nil ]. actualResult := self log. expectedResult := self perform: (aSelector, #Results) asSymbol. actualResult = expectedResult ifTrue: [self logTestResult: 'succeeded'] ifFalse: [self logTestResult: 'failed' ]. ! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:51'! doubleOuterPassTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:49'! doubleOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'dtl 6/1/2004 21:52'! doublePassOuterTest "uses #resume" [[[self doSomething. MyTestNotification signal. self doSomethingExceptional] on: MyTestNotification do: [:ex | ex pass. self doSomethingExceptional]] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:27'! simpleIsNestedTest "uses resignalAs:" [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex isNested "expecting to detect handler in #runTest:" ifTrue: [self doYetAnotherThing. ex resignalAs: MyTestNotification new]]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tpr 5/27/2004 21:50'! simpleOuterTest "uses #resume" [[self doSomething. MyTestNotification signal. "self doSomethingElse" self doSomethingExceptional] on: MyTestNotification do: [:ex | ex outer. self doSomethingElse]] on: MyTestNotification do: [:ex | self doYetAnotherThing. ex resume]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:37'! simplePassTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | self doYetAnotherThing. ex pass "expecting handler in #runTest:"]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 02:12'! simpleResignalAsTest "ExceptionTester new simpleResignalAsTest" [self doSomething. MyTestNotification signal. self doSomethingElse] on: MyTestNotification do: [:ex | ex resignalAs: MyTestError new]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'RAA 12/8/2000 12:58'! simpleResumeTest "see if we can resume twice" | it | [self doSomething. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. it := MyResumableTestError signal. it = 3 ifTrue: [self doSomethingElse]. ] on: MyResumableTestError do: [:ex | self doYetAnotherThing. ex resume: 3]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:02'! simpleRetryTest | theMeaningOfLife | theMeaningOfLife := nil. [self doSomething. theMeaningOfLife == nil ifTrue: [MyTestError signal] ifFalse: [self doSomethingElse]] on: MyTestError do: [:ex | theMeaningOfLife := 42. self doYetAnotherThing. ex retry]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 01:03'! simpleRetryUsingTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex retryUsing: [self doYetAnotherThing]]! ! !ExceptionTester methodsFor: 'signaledException tests' stamp: 'tfei 6/13/1999 00:59'! simpleReturnTest | it | it := [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex return: 3]. it = 3 ifTrue: [self doYetAnotherThing]! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'dtl 6/1/2004 21:56'! doubleOuterPassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'dtl 6/1/2004 21:56'! doublePassOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:09'! simpleIsNestedTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'! simpleOuterTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:10'! simplePassTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:11'! simpleResignalAsTestResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'RAA 12/8/2000 12:59'! simpleResumeTestResults "see if we can resume twice" ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'! simpleRetryTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 01:23'! simpleRetryUsingTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'signaledException results' stamp: 'tfei 6/13/1999 02:22'! simpleReturnTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !ExceptionTests methodsFor: 'private' stamp: 'md 3/25/2003 23:40'! assertSuccess: anExceptionTester self should: [ ( anExceptionTester suiteLog first) endsWith: 'succeeded'].! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'dtl 6/1/2004 21:54'! testDoubleOuterPass self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'dtl 6/1/2004 21:54'! testDoublePassOuter self assertSuccess: (ExceptionTester new runTest: #doublePassOuterTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:43'! testDoubleResume self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'! testNonResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'! testResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #resumableFallOffTheEndHandler ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:44'! testSignalFromHandlerActionTest self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'! testSimpleEnsure self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:45'! testSimpleEnsureTestWithError self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithError ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:46'! testSimpleEnsureTestWithNotification self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:45'! testSimpleEnsureTestWithUparrow self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithUparrow ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:46'! testSimpleIsNested self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:41'! testSimpleOuter self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:42'! testSimplePass self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:43'! testSimpleResignalAs self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'! testSimpleResume self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'! testSimpleRetry self assertSuccess: (ExceptionTester new runTest: #simpleRetryTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:47'! testSimpleRetryUsing self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! ! !ExceptionTests methodsFor: 'testing-ExceptionTester' stamp: 'md 3/25/2003 23:48'! testSimpleReturn self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 21:59'! testNonResumableOuter self should: [ [Error signal. 4] on: Error do: [:ex | ex outer. ex return: 5] ] raise: Error ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! testNonResumablePass self should: [ [Error signal. 4] on: Error do: [:ex | ex pass. ex return: 5] ] raise: Error ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! testResumableOuter | result | result _ [Notification signal. 4] on: Notification do: [:ex | ex outer. ex return: 5]. self assert: result == 5 ! ! !ExceptionTests methodsFor: 'testing-outer' stamp: 'dtl 6/1/2004 22:00'! testResumablePass | result | result _ [Notification signal. 4] on: Notification do: [:ex | ex pass. ex return: 5]. self assert: result == 4 ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'! testNoTimeout self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'! testTimeout self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutTest ) ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:41'! testTimeoutWithZeroDuration self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! ! !ExternalAddress methodsFor: 'converting' stamp: 'bf 2/21/2001 23:50'! asInteger "convert address to integer" ^ self asByteArrayPointer unsignedLongAt: 1! ! !ExternalAddress methodsFor: 'converting' stamp: 'bf 2/21/2001 23:50'! fromInteger: address "set my handle to point at address." "Do we really need this? bf 2/21/2001 23:48" | pointer | pointer _ ByteArray new: 4. pointer unsignedLongAt: 1 put: address. self basicAt: 1 put: (pointer byteAt: 1); basicAt: 2 put: (pointer byteAt: 2); basicAt: 3 put: (pointer byteAt: 3); basicAt: 4 put: (pointer byteAt: 4) ! ! !ExternalAddress methodsFor: 'printing' stamp: 'laza 3/29/2004 18:33'! printOn: aStream "print this as a hex address ('@ 16rFFFFFFFF') to distinguish it from ByteArrays" aStream nextPutAll: '@ '; nextPutAll: (self asInteger storeStringBase: 16 length: 11 padded: true)! ! !ExternalDropHandler methodsFor: 'testing' stamp: 'mir 1/10/2002 16:36'! matchesExtension: aExtension (self extension isNil or: [aExtension isNil]) ifTrue: [^false]. ^extension = aExtension! ! !ExternalDropHandler methodsFor: 'testing' stamp: 'mir 1/10/2002 16:35'! matchesTypes: types (self type isNil or: [types isNil]) ifTrue: [^false]. ^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! ! !ExternalDropHandler methodsFor: 'initialize' stamp: 'mir 1/10/2002 17:17'! type: aType extension: anExtension action: anAction action _ anAction. type _ aType. extension _ anExtension! ! !ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'! extension ^extension! ! !ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:29'! handle: dropStream in: pasteUp dropEvent: anEvent | numArgs | numArgs _ action numArgs. numArgs == 1 ifTrue: [^action value: dropStream]. numArgs == 2 ifTrue: [^action value: dropStream value: pasteUp]. numArgs == 3 ifTrue: [^action value: dropStream value: pasteUp value: anEvent]. self error: 'Wrong number of args for dop action.'! ! !ExternalDropHandler methodsFor: 'accessing' stamp: 'mir 1/10/2002 15:54'! type ^type! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:17'! defaultHandler DefaultHandler ifNil: [DefaultHandler _ ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]]. ^DefaultHandler! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 16:54'! defaultHandler: externalDropHandler DefaultHandler _ externalDropHandler! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 15:37'! lookupExternalDropHandler: stream | types extension serviceHandler | types _ stream mimeTypes. types ifNotNil: [ self registeredHandlers do: [:handler | (handler matchesTypes: types) ifTrue: [^handler]]]. extension _ FileDirectory extensionFor: stream name. self registeredHandlers do: [:handler | (handler matchesExtension: extension) ifTrue: [^handler]]. serviceHandler := self lookupServiceBasedHandler: stream. ^serviceHandler ifNil: [self defaultHandler]! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 8/24/2004 17:15'! lookupServiceBasedHandler: dropStream "the file was just droped, let's do our job" | fileName services theOne | fileName := dropStream name. services := (FileList itemsForFile: fileName) reject: [:svc | self unwantedSelectors includes: svc selector]. "no service, default behavior" services isEmpty ifTrue: [^nil]. theOne := self chooseServiceFrom: services. ^theOne ifNotNil: [ExternalDropHandler type: nil extension: nil action: [:stream | theOne performServiceFor: stream]]! ! !ExternalDropHandler class methodsFor: 'accessing' stamp: 'mir 1/10/2002 17:19'! registerHandler: aHandler self registeredHandlers add: aHandler! ! !ExternalDropHandler class methodsFor: 'class initialization' stamp: 'mir 1/10/2002 17:37'! initialize "ExternalDropHandler initialize" self resetRegisteredHandlers. self registerHandler: self defaultImageHandler; registerHandler: self defaultGZipHandler; registerHandler: self defaultProjectHandler! ! !ExternalDropHandler class methodsFor: 'class initialization' stamp: 'nk 6/12/2004 16:15'! registerStandardExternalDropHandlers "ExternalDropHandler registerStandardExternalDropHandlers" self registeredHandlers add: ( ExternalDropHandler type: 'image/' extension: nil action: [:stream :pasteUp :event | pasteUp addMorph: (World drawingClass withForm: (Form fromBinaryStream: stream binary)) centeredNear: event position])! ! !ExternalDropHandler class methodsFor: 'instance creation' stamp: 'mir 1/10/2002 17:16'! type: aType extension: anExtension action: anAction ^self new type: aType extension: anExtension action: anAction ! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 8/24/2004 15:28'! chooseServiceFrom: aCollection "private - choose a service from aCollection asking the user if needed" | menu | aCollection size = 1 ifTrue: [^ aCollection anyOne]. "" menu := CustomMenu new. aCollection do: [:each | menu add: each label action: each]. ^ menu startUp! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:23'! defaultGZipHandler ^ExternalDropHandler type: nil extension: 'gz' action: [:stream :pasteUp :event | stream viewGZipContents]! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'nk 6/12/2004 09:24'! defaultImageHandler | image sketch | ^ExternalDropHandler type: 'image/' extension: nil action: [:stream :pasteUp :event | stream binary. image _ Form fromBinaryStream: ((RWBinaryOrTextStream with: stream contents) reset). Project current resourceManager addResource: image url: (FileDirectory urlForFileNamed: stream name) asString. sketch _ World drawingClass withForm: image. pasteUp addMorph: sketch centeredNear: event position] fixTemps! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 17:38'! defaultProjectHandler ^ExternalDropHandler type: nil extension: 'pr' action: [:stream | ProjectLoading openName: nil stream: stream fromDirectory: nil withProjectView: nil] ! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'! registeredHandlers RegisteredHandlers ifNil: [RegisteredHandlers _ OrderedCollection new]. ^RegisteredHandlers! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 1/10/2002 15:57'! resetRegisteredHandlers RegisteredHandlers _ nil! ! !ExternalDropHandler class methodsFor: 'private' stamp: 'mir 8/24/2004 15:28'! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! !ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:50'! initialize "ExternalFunction initialize" self initializeErrorMessages.! ! !ExternalFunction class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:53'! initializeErrorMessages "ExternalFunction initializeErrorConstants" FFIErrorMessages _ Dictionary new. FFIErrorMessages at: FFINoCalloutAvailable put: 'Callout mechanism not available'; at: FFIErrorGenericError put: 'A call to an external function failed'; at: FFIErrorNotFunction put: 'Only ExternalFunctions can be called'; at: FFIErrorBadArgs put: 'Bad arguments in primitive invokation'; at: FFIErrorBadArg put: 'Bad argument for external function'; at: FFIErrorIntAsPointer put: 'Cannot use integer as pointer'; at: FFIErrorBadAtomicType put: 'Unknown atomic type in external call'; at: FFIErrorCoercionFailed put: 'Could not coerce arguments'; at: FFIErrorWrongType put: 'Wrong type in external call'; at: FFIErrorStructSize put: 'Bad structure size in external call'; at: FFIErrorCallType put: 'Unsupported calling convention'; at: FFIErrorBadReturn put: 'Cannot return the given type'; at: FFIErrorBadAddress put: 'Bad function address'; at: FFIErrorNoModule put: 'No module to load address from'; at: FFIErrorAddressNotFound put: 'Unable to find function address'; at: FFIErrorAttemptToPassVoid put: 'Cannot pass ''void'' parameter'; at: FFIErrorModuleNotFound put: 'External module not found'; at: FFIErrorBadExternalLibrary put: 'External library is invalid'; at: FFIErrorBadExternalFunction put: 'External function is invalid'; at: FFIErrorInvalidPointer put: 'Attempt to pass invalid pointer'; yourself! ! !ExternalSettings commentStamp: '' prior: 0! ExternalSettings manages settings kept externally, e.g. files. Objects can register themselves as clients to be notified at startup time to read their settings. Eventually all the preferences should be managed through this mechanism. ! !ExternalSettings class methodsFor: 'private' stamp: 'mir 6/25/2001 18:46'! registeredClients RegisteredClients ifNil: [RegisteredClients _ Set new]. ^RegisteredClients! ! !ExternalSettings class methodsFor: 'accessing' stamp: 'sw 1/25/2002 12:39'! assuredPreferenceDirectory "Answer the preference directory, creating it if necessary" | prefDir | prefDir _ self preferenceDirectory. prefDir ifNil: [prefDir _ FileDirectory default directoryNamed: self preferenceDirectoryName. prefDir assureExistence]. ^ prefDir! ! !ExternalSettings class methodsFor: 'accessing' stamp: 'mir 8/23/2002 14:22'! parseServerEntryArgsFrom: stream "Args are in the form : delimited by end of line. It's not a very robust format and should be replaced by something like XML later. But it avoids evaluating the entries for security reasons." | entries lineStream entryName entryValue | entries _ Dictionary new. stream skipSeparators. [stream atEnd] whileFalse: [ lineStream _ ReadStream on: stream nextLine. entryName _ lineStream upTo: $:. lineStream skipSeparators. entryValue _ lineStream upToEnd. (entryName isEmptyOrNil or: [entryValue isEmptyOrNil]) ifFalse: [entries at: entryName put: entryValue withoutTrailingBlanks]. stream skipSeparators]. ^entries! ! !ExternalSettings class methodsFor: 'accessing' stamp: 'mir 11/16/2001 13:33'! preferenceDirectoryName ^'prefs'! ! !ExternalSettings class methodsFor: 'accessing' stamp: 'mir 6/25/2001 18:45'! registerClient: anObject "Register anObject as a settings client to be notified on startup." self registeredClients add: anObject! ! !ExternalSettings class methodsFor: 'class initialization' stamp: 'ar 8/23/2001 22:56'! initialize "ExternalSettings initialize" "Order: ExternalSettings, SecurityManager, AutoStart" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self! ! !ExternalSettings class methodsFor: 'class initialization' stamp: 'mir 8/22/2001 15:17'! shutDown "Look for external defs and load them." "ExternalSettings shutDown" self registeredClients do: [:client | client releaseExternalSettings]! ! !ExternalSettings class methodsFor: 'class initialization' stamp: 'mir 11/16/2001 13:29'! startUp "Look for external defs and load them." "ExternalSettings startUp" | prefDir | prefDir _ self preferenceDirectory. prefDir ifNil: [^self]. self registeredClients do: [:client | client fetchExternalSettingsIn: prefDir]! ! !ExternalSettings class methodsFor: '-- all --' stamp: 'sd 9/30/2003 14:01'! preferenceDirectory | prefDirName path | prefDirName := self preferenceDirectoryName. path := SmalltalkImage current vmPath. ^(FileDirectory default directoryExists: prefDirName) ifTrue: [FileDirectory default directoryNamed: prefDirName] ifFalse: [ ((FileDirectory on: path) directoryExists: prefDirName) ifTrue: [(FileDirectory on: path) directoryNamed: prefDirName] ifFalse: [nil]] ! ! !ExternalStructure methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:11'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." self class fields size > 0 ifTrue: [^ExternalStructureInspector] ifFalse: [^super inspectorClass]! ! !ExternalStructure methodsFor: 'printing' stamp: 'gk 3/1/2005 12:07'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all the record's variables." | fields | fields _ self class fields. (fields isEmpty or: [fields first isNil]) ifTrue: [fields _ #()] ifFalse: [(fields first isKindOf: Array) ifFalse: [fields _ Array with: fields]]. fields do: [ :field | field first notNil ifTrue: [ aStream nextPutAll: field first; nextPut: $:; space; tab. (self perform: field first) printOn: aStream. aStream cr]].! ! !ExternalStructure class methodsFor: 'field definition' stamp: 'gk 3/1/2005 12:06'! compileAlias: spec withAccessors: aBool "Define all the fields in the receiver. Return the newly compiled spec." | fieldName fieldType isPointerField externalType | fieldName _ spec first. fieldType _ spec second. isPointerField _ fieldType last = $*. fieldType _ fieldType copyWithout: $*. externalType _ ExternalType atomicTypeNamed: fieldType. externalType == nil ifTrue:["non-atomic" Symbol hasInterned: fieldType ifTrue:[:sym| externalType _ ExternalType structTypeNamed: sym]]. externalType == nil ifTrue:[ Transcript show:'(', fieldType,' is void)'. externalType _ ExternalType void]. isPointerField ifTrue:[externalType _ externalType asPointerType]. (fieldName notNil and:[aBool]) ifTrue:[ self defineAliasAccessorsFor: fieldName type: externalType]. isPointerField ifTrue:[compiledSpec _ WordArray with: (ExternalType structureSpec bitOr: ExternalType pointerSpec)] ifFalse:[compiledSpec _ externalType compiledSpec]. ExternalType noticeModificationOf: self. ^compiledSpec! ! !ExternalStructure class methodsFor: 'field definition' stamp: 'gk 3/1/2005 12:07'! compileFields: specArray withAccessors: aBool "Define all the fields in the receiver. Return the newly compiled spec." | fieldName fieldType isPointerField externalType byteOffset typeSize typeSpec selfRefering | (specArray size > 0 and: [specArray first class ~~ Array]) ifTrue: [^ self compileAlias: specArray withAccessors: aBool]. byteOffset _ 1. typeSpec _ WriteStream on: (WordArray new: 10). typeSpec nextPut: FFIFlagStructure. "dummy for size" specArray do: [:spec | fieldName _ spec first. fieldType _ spec second. isPointerField _ fieldType last = $*. fieldType _ (fieldType findTokens: ' *') first. externalType _ ExternalType atomicTypeNamed: fieldType. selfRefering _ externalType == nil and: fieldType = self asString and: isPointerField. selfRefering ifTrue: [externalType _ ExternalType void asPointerType] ifFalse: [externalType == nil ifTrue: ["non-atomic" Symbol hasInterned: fieldType ifTrue: [:sym | externalType _ ExternalType structTypeNamed: sym]]. externalType == nil ifTrue: [Transcript show: '(' , fieldType , ' is void)'. externalType _ ExternalType void]. isPointerField ifTrue: [externalType _ externalType asPointerType]]. typeSize _ externalType byteSize. spec size > 2 ifTrue: ["extra size" spec third < typeSize ifTrue: [^ self error: 'Explicit type size is less than expected']. typeSize _ spec third]. (fieldName notNil and: [aBool]) ifTrue: [self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType]. typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize). byteOffset _ byteOffset + typeSize]. compiledSpec _ typeSpec contents. compiledSpec at: 1 put: (byteOffset - 1 bitOr: FFIFlagStructure). ExternalType noticeModificationOf: self. ^ compiledSpec! ! !ExternalStructureInspector methodsFor: 'accessing' stamp: 'gk 3/1/2005 12:07'! recordFieldList | fields | fields _ object class fields. (fields first isKindOf: Array) ifFalse: [fields _ Array with: fields]. ^fields collect: [ :field | field first ] thenSelect: [:name | name notNil]! ! !ExternalType class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 18:45'! initializeFFIConstants "ExternalType initialize" AtomicTypeNames _ IdentityDictionary new. AtomicSelectors _ IdentityDictionary new. AtomicTypeNames at: FFITypeVoid put: 'void'; at: FFITypeBool put: 'bool'; at: FFITypeUnsignedByte put: 'byte'; at: FFITypeSignedByte put: 'sbyte'; at: FFITypeUnsignedShort put: 'ushort'; at: FFITypeSignedShort put: 'short'; at: FFITypeUnsignedInt put: 'ulong'; at: FFITypeSignedInt put: 'ulong'; at: FFITypeUnsignedLongLong put: 'ulonglong'; at: FFITypeSignedLongLong put: 'longlong'; at: FFITypeUnsignedChar put: 'char'; at: FFITypeSignedChar put: 'schar'; at: FFITypeSingleFloat put: 'float'; at: FFITypeDoubleFloat put: 'double'; yourself. AtomicSelectors at: FFITypeVoid put: #voidAt:; at: FFITypeBool put: #booleanAt:; at: FFITypeUnsignedByte put: #unsignedByteAt:; at: FFITypeSignedByte put: #signedByteAt:; at: FFITypeUnsignedShort put: #unsignedShortAt:; at: FFITypeSignedShort put: #signedShortAt:; at: FFITypeUnsignedInt put: #unsignedLongAt:; at: FFITypeSignedInt put: #signedLongAt:; at: FFITypeUnsignedLongLong put: #unsignedLongLongAt:; at: FFITypeSignedLongLong put: #signedLongLongAt:; at: FFITypeUnsignedChar put: #unsignedCharAt:; at: FFITypeSignedChar put: #signedCharAt:; at: FFITypeSingleFloat put: #floatAt:; at: FFITypeDoubleFloat put: #doubleAt:; yourself! ! !EyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 1.0 g: 0.968 b: 0.935! ! !EyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:25'! initialize "initialize the state of the receiver" super initialize. "" self extent: 30 @ 37. self addMorphFront: (iris _ EllipseMorph new extent: 6 @ 6; borderWidth: 0; color: Color black). self lookAtFront! ! !FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:54'! initialize "FFIConstants initialize" self initializeTypeConstants. self initializeErrorConstants. self initializeCallingConventions.! ! !FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:50'! initializeCallingConventions FFICallTypeCDecl := 0. FFICallTypeApi := 1. ! ! !FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:49'! initializeErrorConstants "ExternalFunction initializeErrorConstants" "No callout mechanism available" FFINoCalloutAvailable := -1. "generic error" FFIErrorGenericError := 0. "primitive invoked without ExternalFunction" FFIErrorNotFunction := 1. "bad arguments to primitive call" FFIErrorBadArgs := 2. "generic bad argument" FFIErrorBadArg := 3. "int passed as pointer" FFIErrorIntAsPointer := 4. "bad atomic type (e.g., unknown)" FFIErrorBadAtomicType := 5. "argument coercion failed" FFIErrorCoercionFailed := 6. "Type check for non-atomic types failed" FFIErrorWrongType := 7. "struct size wrong or too large" FFIErrorStructSize := 8. "unsupported calling convention" FFIErrorCallType := 9. "cannot return the given type" FFIErrorBadReturn := 10. "bad function address" FFIErrorBadAddress := 11. "no module given but required for finding address" FFIErrorNoModule := 12. "function address not found" FFIErrorAddressNotFound := 13. "attempt to pass 'void' parameter" FFIErrorAttemptToPassVoid := 14. "module not found" FFIErrorModuleNotFound := 15. "external library invalid" FFIErrorBadExternalLibrary := 16. "external function invalid" FFIErrorBadExternalFunction := 17. "ExternalAddress points to ST memory (don't you dare to do this!!)" FFIErrorInvalidPointer := 18.! ! !FFIConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 18:34'! initializeTypeConstants "type void" FFITypeVoid := 0. "type bool" FFITypeBool := 1. "basic integer types. note: (integerType anyMask: 1) = integerType isSigned" FFITypeUnsignedByte := 2. FFITypeSignedByte := 3. FFITypeUnsignedShort := 4. FFITypeSignedShort := 5. FFITypeUnsignedInt := 6. FFITypeSignedInt := 7. "64bit types" FFITypeUnsignedLongLong := 8. FFITypeSignedLongLong := 9. "special integer types" FFITypeUnsignedChar := 10. FFITypeSignedChar := 11. "float types" FFITypeSingleFloat := 12. FFITypeDoubleFloat := 13. "type flags" FFIFlagAtomic := 16r40000. "type is atomic" FFIFlagPointer := 16r20000. "type is pointer to base type" FFIFlagStructure := 16r10000. "baseType is structure of 64k length" FFIStructSizeMask := 16rFFFF. "mask for max size of structure" FFIAtomicTypeMask := 16r0F000000. "mask for atomic type spec" FFIAtomicTypeShift := 24. "shift for atomic type" ! ! !FFT methodsFor: 'plugin-testing' stamp: 'ar 2/13/2001 21:10'! pluginTransformData: forward "Plugin testing -- if the primitive is not implemented or cannot be found run the simulation. See also: FFTPlugin" ^(Smalltalk at: #FFTPlugin ifAbsent:[^self primitiveFailed]) doPrimitive: 'primitiveFFTTransformData'.! ! !FTPClient methodsFor: 'private' stamp: 'mir 2/19/2002 18:27'! closeDataSocket self dataSocket ifNotNil: [ self dataSocket closeAndDestroy. self dataSocket: nil] ! ! !FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 16:24'! dataSocket ^dataSocket! ! !FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 18:23'! dataSocket: aSocket dataSocket _ aSocket! ! !FTPClient methodsFor: 'private' stamp: 'mir 4/7/2003 17:20'! login self user ifNil: [^self]. ["repeat both USER and PASS since some servers require it" self sendCommand: 'USER ', self user. "331 Password required" self lookForCode: 331. "will ask user, if needed" self sendCommand: 'PASS ', self password. "230 User logged in" ([self lookForCode: 230.] on: TelnetProtocolError do: [false]) == false ] whileTrue: [ (LoginFailedException protocolInstance: self) signal: self lastResponse] ! ! !FTPClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:14'! sendStreamContents: aStream self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 2/13/2002 18:05'! abortDataConnection self sendCommand: 'ABOR'. self closeDataSocket! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! ascii self sendCommand: 'TYPE A'. self lookForCode: 200! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! binary self sendCommand: 'TYPE I'. self lookForCode: 200! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:52'! changeDirectoryTo: newDirName self sendCommand: 'CWD ' , newDirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:11'! deleteDirectory: dirName self sendCommand: 'RMD ' , dirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:12'! deleteFileNamed: fileName self sendCommand: 'DELE ' , fileName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 2/20/2002 13:53'! getDirectory | dirList | self openPassiveDataConnection. self sendCommand: 'LIST'. dirList _ self getData. self checkResponse. self checkResponse. ^dirList ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:50'! getFileList | dirList | self openPassiveDataConnection. self sendCommand: 'NLST'. dirList _ self getData. self checkResponse. self checkResponse. ^dirList ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 19:23'! getFileNamed: remoteFileName | data | self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. data _ self getData. self checkResponse. ^data ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 5/9/2003 15:50'! getFileNamed: remoteFileName into: dataStream self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. self getDataInto: dataStream. self closeDataSocket. self checkResponse! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 19:03'! getPartial: limit fileNamed: remoteFileName into: dataStream | data | self openPassiveDataConnection. self sendCommand: 'RETR ', remoteFileName. [self checkResponse] on: TelnetProtocolError do: [:ex | self closeDataSocket. ex pass]. data _ self get: limit dataInto: dataStream. self abortDataConnection. ^data ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/12/2002 18:39'! loginUser: userName password: passwdString self user: userName. self password: passwdString. self login! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:10'! makeDirectory: newDirName self sendCommand: 'MKD ' , newDirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 17:51'! openDataSocket: remoteHostAddress port: dataPort dataSocket _ Socket new. dataSocket connectTo: remoteHostAddress port: dataPort! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:55'! passive self sendCommand: 'PASV'. self lookForCode: 227! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 16:54'! putFileNamed: filePath as: fileNameOnServer "FTP a file to the server." | fileStream | fileStream _ FileStream readOnlyFileNamed: filePath. fileStream ifNil: [(FileDoesNotExistException fileName: filePath) signal]. self putFileStreamContents: fileStream as: fileNameOnServer ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 12/8/2003 16:54'! putFileStreamContents: fileStream as: fileNameOnServer "FTP a file to the server." self openPassiveDataConnection. self sendCommand: 'STOR ', fileNameOnServer. fileStream reset. [self sendStreamContents: fileStream] ensure: [self closeDataSocket]. self checkResponse. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/14/2002 16:43'! pwd | result | self sendCommand: 'PWD'. self lookForCode: 257. result := self lastResponse. ^result copyFrom: (result indexOf: $")+1 to: (result lastIndexOf: $")-1! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 10/31/2000 13:12'! quit self sendCommand: 'QUIT'. self close! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:50'! removeFileNamed: remoteFileName self sendCommand: 'DELE ', remoteFileName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'nk 1/26/2005 16:40'! renameFileNamed: oldFileName to: newFileName self sendCommand: 'RNFR ' , oldFileName. self lookForCode: 350. self sendCommand: 'RNTO ' , newFileName. self lookForCode: 250! ! !FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:06'! get: limit dataInto: dataStream "Reel in data until the server closes the connection or the limit is reached. At the same time, watch for errors on otherSocket." | buf bytesRead currentlyRead | currentlyRead _ 0. buf _ String new: 4000. [currentlyRead < limit and: [self dataSocket isConnected or: [self dataSocket dataAvailable]]] whileTrue: [ self checkForPendingError. bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf. 1 to: (bytesRead min: (limit - currentlyRead)) do: [:ii | dataStream nextPut: (buf at: ii)]. currentlyRead _ currentlyRead + bytesRead]. dataStream reset. "position: 0." ^ dataStream! ! !FTPClient methodsFor: 'private protocol' stamp: 'mir 2/13/2002 18:06'! getData | dataStream | dataStream _ RWBinaryOrTextStream on: (String new: 4000). self getDataInto: dataStream. self closeDataSocket. ^dataStream contents ! ! !FTPClient methodsFor: 'private protocol' stamp: 'svp 10/28/2003 11:04'! getDataInto: dataStream "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Don't know how much is coming. Put the data on the stream." | buf bytesRead | buf _ String new: 4000. [self dataSocket isConnected or: [self dataSocket dataAvailable]] whileTrue: [ self checkForPendingError. bytesRead _ self dataSocket receiveDataWithTimeoutInto: buf. 1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]]. dataStream reset. "position: 0." ^ dataStream! ! !FTPClient methodsFor: 'private protocol' stamp: 'mir 4/7/2003 16:59'! openPassiveDataConnection | portInfo list dataPort remoteHostAddress | self sendCommand: 'PASV'. self lookForCode: 227 ifDifferent: [:response | (TelnetProtocolError protocolInstance: self) signal: 'Could not enter passive mode: ' , response]. portInfo _ (self lastResponse findTokens: '()') at: 2. list _ portInfo findTokens: ','. remoteHostAddress _ ByteArray with: (list at: 1) asNumber with: (list at: 2) asNumber with: (list at: 3) asNumber with: (list at: 4) asNumber. dataPort _ (list at: 5) asNumber * 256 + (list at: 6) asNumber. self openDataSocket: remoteHostAddress port: dataPort ! ! !FTPClient commentStamp: 'mir 5/12/2003 17:55' prior: 0! A minimal FTP client program. Could store all state in inst vars, and use an instance to represent the full state of a connection in progress. But simpler to do all that in one method and have it be a complete transaction. Always operates in passive mode (PASV). All connections are initiated from client in order to get through firewalls. See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use. See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.! !FTPClient class methodsFor: 'accessing' stamp: 'mir 10/30/2000 20:10'! defaultPortNumber ^21! ! !FTPClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:08'! logFlag ^#ftp! ! !FTPClient class methodsFor: 'accessing' stamp: 'mir 2/13/2002 17:50'! rawResponseCodes #(200 'Command okay.' 500 'Syntax error, command unrecognized. This may include errors such as command line too long.' 501 'Syntax error in parameters or arguments.' 202 'Command not implemented, superfluous at this site.' 502 'Command not implemented.' 503 'Bad sequence of commands.' 504 'Command not implemented for that parameter.' 110 'Restart marker reply. In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm Where yyyy is User-process data stream marker, and mmmm server''s equivalent marker (note the spaces between markers and "=").' 211 'System status, or system help reply.' 212 'Directory status.' 213 'File status.' 214 'Help message. On how to use the server or the meaning of a particular non-standard command. This reply is useful only to the human user.' 215 'NAME system type. Where NAME is an official system name from the list in the Assigned Numbers document.' 120 'Service ready in nnn minutes.' 220 'Service ready for new user.' 221 'Service closing control connection. Logged out if appropriate.' 421 'Service not available, closing control connection. This may be a reply to any command if the service knows it must shut down.' 125 'Data connection already open; transfer starting.' 225 'Data connection open; no transfer in progress.' 425 'Can''t open data connection.' 226 'Closing data connection. Requested file action successful (for example, file transfer or file abort).' 426 'Connection closed; transfer aborted.' 227 'Entering Passive Mode (h1,h2,h3,h4,p1,p2).' 230 'User logged in, proceed.' 530 'Not logged in.' 331 'User name okay, need password.' 332 'Need account for login.' 532 'Need account for storing files.' 150 'File status okay; about to open data connection.' 250 'Requested file action okay, completed.' 257 '"PATHNAME" created.' 350 'Requested file action pending further information.' 450 'Requested file action not taken. File unavailable (e.g., file busy).' 550 'Requested action not taken. File unavailable (e.g., file not found, no access).' 451 'Requested action aborted. Local error in processing.' 551 'Requested action aborted. Page type unknown.' 452 'Requested action not taken. Insufficient storage space in system.' 552 'Requested file action aborted. Exceeded storage allocation (for current directory or dataset).' 553 'Requested action not taken. File name not allowed.') ! ! !FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 07:47'! defaultAction self resume! ! !FTPConnectionException methodsFor: 'as yet unclassified' stamp: 'RAA 3/14/2001 15:57'! isResumable ^true! ! !FWT methodsFor: 'access' stamp: 'zz 3/2/2004 08:13'! coeffs "Return all coefficients needed to reconstruct the original samples" | header csize strm | header _ Array with: nSamples with: nLevels with: alpha with: beta. csize _ header size. 1 to: nLevels do: [:i | csize _ csize + (transform at: i*2) size]. csize _ csize + (transform at: nLevels*2-1) size. coeffs _ Array new: csize. strm _ WriteStream on: coeffs. strm nextPutAll: header. 1 to: nLevels do: [:i | strm nextPutAll: (transform at: i*2)]. strm nextPutAll: (transform at: nLevels*2-1). ^ coeffs! ! !FaceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !FaceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:49'! initialize "initialize the state of the receiver" super initialize. "" self addMorph: (leftEye _ EyeMorph new); addMorph: (rightEye _ EyeMorph new); addMorph: (lips _ LipsMorph new). leftEye position: self position. rightEye position: leftEye extent x @ 0 + leftEye position. lips position: 0 @ 20 + (leftEye bottomRight + rightEye bottomLeft - lips extent // 2). self bounds: self fullBounds! ! !False methodsFor: 'printing' stamp: 'ajh 7/1/2004 10:36'! asBit ^ 0! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:02'! testAND self assert: (false & true) = false. self assert: (false & false) = false.! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:05'! testAnd self assert: (false and: ['alternativeBlock']) = false.! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:59'! testIfFalse self should: [(false ifFalse: ['alternativeBlock']) = 'alternativeBlock']. ! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:07'! testIfFalseIfTrue self assert: (false ifFalse: ['falseAlternativeBlock'] ifTrue: ['trueAlternativeBlock']) = 'falseAlternativeBlock'. ! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:04'! testIfTrue self assert: (false ifTrue: ['alternativeBlock']) = nil. ! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:09'! testIfTrueIfFalse self assert: (false ifTrue: ['trueAlternativeBlock'] ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/25/2003 23:16'! testNew self should: [False new] raise: TestResult error. ! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/5/2003 00:30'! testNot self should: [false not = true].! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 16:44'! testOR self assert: (false | true) = true. self assert: (false | false) = false.! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 17:05'! testOr self assert: (false or: ['alternativeBlock']) = 'alternativeBlock'.! ! !FalseTest methodsFor: 'testing' stamp: 'md 3/2/2003 16:41'! testPrintOn self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! ! !FalseTest commentStamp: '' prior: 0! This is the unit test for the class False. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:51'! borderAndButtonColor ^Color r: 0.729 g: 0.365 b: 0.729! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/9/2000 21:14'! buttonWithAction: aSymbol label: labelString help: helpString ^self newColumn wrapCentering: #center; cellPositioning: #topCenter; addMorph: ( SimpleButtonMorph new color: self borderAndButtonColor; target: self; actionSelector: aSymbol; label: labelString; setBalloonText: helpString ) ! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:35'! forgetIt morphicWindow ifNotNil: [ morphicWindow delete ]. mvcWindow ifNotNil: [ mvcWindow controller close ]. ! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:42'! newColumn ^AlignmentMorph newColumn color: self staticBackgroundColor! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:41'! newRow ^AlignmentMorph newRow color: self staticBackgroundColor! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/10/2000 15:46'! openInMorphic "open an interface for sending a mail message with the given initial text " | buttonsList container toField subjectField | buttonsList _ self newRow. buttonsList wrapCentering: #center; cellPositioning: #leftCenter. buttonsList addMorphBack: ( (self buttonWithAction: #submit label: 'send later' help: 'add this to the queue of messages to be sent') ); addMorphBack: ( (self buttonWithAction: #sendNow label: 'send now' help: 'send this message immediately') ); addMorphBack: ( (self buttonWithAction: #forgetIt label: 'forget it' help: 'forget about sending this message') ). morphicWindow _ container _ AlignmentMorphBob1 new borderWidth: 8; borderColor: self borderAndButtonColor; color: Color white. container addMorphBack: (buttonsList vResizing: #shrinkWrap; minHeight: 25; yourself); addMorphBack: ((self simpleString: 'To:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((toField _ PluggableTextMorph on: self text: #to accept: #to:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself ); addMorphBack: ((self simpleString: 'Subject:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((subjectField _ PluggableTextMorph on: self text: #subject accept: #subject:) hResizing: #spaceFill; vResizing: #rigid; height: 50; yourself ); addMorphBack: ((self simpleString: 'Message:') vResizing: #shrinkWrap; minHeight: 18; yourself); addMorphBack: ((textEditor _ PluggableTextMorph on: self text: #messageText accept: #messageText:) hResizing: #spaceFill; vResizing: #spaceFill; yourself ). textFields _ {toField. subjectField. textEditor}. container extent: 300@400; openInWorld.! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'ar 11/9/2000 20:39'! simpleString: aString ^self newRow layoutInset: 2; addMorphBack: (StringMorph contents: aString) lock! ! !FancyMailComposition methodsFor: 'morphic gui' stamp: 'RAA 7/7/2000 17:38'! staticBackgroundColor ^Color veryLightGray! ! !FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 18:48'! subject ^subject ! ! !FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 19:02'! subject: x subject _ x. self changed: #subject. ^true! ! !FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 18:47'! to ^to! ! !FancyMailComposition methodsFor: 'access' stamp: 'RAA 5/19/2000 19:02'! to: x to _ x. self changed: #to. ^true ! ! !FancyMailComposition methodsFor: 'initialization' stamp: 'nk 7/3/2003 09:41'! celeste: aCeleste to: argTo subject: argSubject initialText: aText theLinkToInclude: linkText "self new celeste: Celeste current to: 'danielv@netvision.net.il' subject: 'Mysubj' initialText: 'atext' theLinkToInclude: 'linkText'" to _ argTo. subject _ argSubject. messageText _ aText. theLinkToInclude _ linkText. textFields _ #(). ! ! !FancyMailComposition methodsFor: 'actions' stamp: 'dvf 6/15/2002 19:09'! completeTheMessage | newText strm | textFields do: [ :each | each hasUnacceptedEdits ifTrue: [ each accept ] ]. newText _ String new: 200. strm _ WriteStream on: newText. strm nextPutAll: 'Content-Type: text/html'; cr; nextPutAll: 'From: ', MailSender userName; cr; nextPutAll: 'To: ',to; cr; nextPutAll: 'Subject: ',subject; cr; cr; nextPutAll: '
'; nextPutAll: messageText asString asHtml; nextPutAll: '

',theLinkToInclude,'
'. ^strm contents ! ! !FancyMailComposition methodsFor: 'actions' stamp: 'RAA 5/19/2000 12:53'! sendNow self submit: true ! ! !FancyMailComposition methodsFor: 'actions' stamp: 'RAA 5/19/2000 12:53'! submit self submit: false! ! !FancyMailComposition methodsFor: 'actions' stamp: 'mir 5/13/2003 10:58'! submit: sendNow | message | messageText _ self breakLines: self completeTheMessage atWidth: 999. message _ MailMessage from: messageText. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: self smtpServer. self forgetIt. ! ! !FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'! mouseDownDefault: evt lastMouse _ nil. formToEdit depth = 1 ifTrue: [self brushColor: (originalForm colorAt: (self pointGriddedFromEvent: evt)) negated]! ! !FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'! mouseDownSelection: evt lastMouse _ nil. currentSelectionMorph ifNotNil: [currentSelectionMorph delete. currentSelectionMorph _ nil]. selectionAnchor _ self pointGriddedFromEvent: evt! ! !FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'! mouseMovePaintBrushMode: evt | p p2 | p _ self pointGriddedFromEvent: evt. lastMouse = p ifTrue: [^ self]. lastMouse ifNil: [lastMouse _ p]. "first point in a stroke" "draw etch-a-sketch style-first horizontal, then vertical" p2 _ p x@lastMouse y. brush drawFrom: lastMouse to: p2. brush drawFrom: p2 to: p. self revealPenStrokes. lastMouse _ p! ! !FatBitsPaint methodsFor: 'events' stamp: 'sw 3/30/2002 16:47'! pointGriddedFromEvent: evt | relativePt | relativePt _ evt cursorPoint - self position. ^ (relativePt x truncateTo: magnification)@(relativePt y truncateTo: magnification) ! ! !FatBitsPaint methodsFor: 'events' stamp: 'nk 4/18/2004 19:04'! toolMenu: evt | menu | menu _ MenuMorph new. menu addTitle: 'Tools'; addStayUpItem. { {'paint brush'. self toolsForPaintBrush}. {'selections'. self toolsForSelection} } do: [:each | menu add: each first target: self selector: #setCurrentToolTo: argumentList: {each second}]. menu toggleStayUp: evt. menu popUpEvent: evt in: self world! ! !FatBitsPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryVeryLightGray! ! !FatBitsPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:54'! initialize "initialize the state of the receiver" super initialize. "" self setCurrentToolTo: self toolsForPaintBrush. formToEdit _ Form extent: 50 @ 40 depth: 8. formToEdit fill: formToEdit boundingBox fillColor: Color veryVeryLightGray. brushSize _ magnification _ 4. brushColor _ Color red. backgroundColor _ Color white. self revert! ! !FatBitsPaint methodsFor: 'menu' stamp: 'dgd 10/8/2003 18:59'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'background color' translated action: #setBackgroundColor:; add: 'pen color' translated action: #setPenColor:; add: 'pen size' translated action: #setPenSize:; add: 'fill' translated action: #fill; add: 'magnification' translated action: #setMagnification:; add: 'accept' translated action: #accept; add: 'revert' translated action: #revert; add: 'inspect' translated action: #inspectForm; add: 'file out' translated action: #fileOut; add: 'selection...' translated action: #selectionMenu:; add: 'tools...' translated action: #toolMenu:! ! !FatBitsPaint methodsFor: 'menu' stamp: 'nb 6/17/2003 12:25'! fileOut | fileName result | result _ StandardFileMenu newFile ifNil: [^Beeper beep]. fileName _ result directory fullNameFor: result name. Cursor normal showWhile: [self unmagnifiedForm writeOnFileNamed: fileName]! ! !FatBitsPaint methodsFor: 'menu' stamp: 'sw 3/30/2002 16:48'! mouseMoveSelectionMode: evt | p | p _ self pointGriddedFromEvent: evt. lastMouse = p ifTrue: [^ self]. currentSelectionMorph ifNil: [currentSelectionMorph _ MarqueeMorph new color: Color transparent; borderWidth: 2; lock. self addMorphFront: currentSelectionMorph. currentSelectionMorph startStepping]. currentSelectionMorph bounds: ((Rectangle encompassing: {p. selectionAnchor}) translateBy: self position). lastMouse _ p! ! !FatBitsPaint methodsFor: 'menu' stamp: 'nk 4/18/2004 19:04'! selectionMenu: evt | menu | (menu _ MenuMorph new) addTitle: 'Edit'; addStayUpItem. { {'edit separately'. #editSelection}. {'copy'. #copySelection}. {'cut'. #cutSelection}. {'paste'. #pasteSelection} } do: [:each | menu add: each first target: self selector: each second argumentList: #()]. menu toggleStayUp: evt. menu popUpEvent: evt in: self world! ! !FileContentsBrowser methodsFor: 'accessing' stamp: 'sw 5/23/2001 14:28'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | aString _ input asString. aText _ input asText. editSelection == #editComment ifTrue: [theClass _ self selectedClass. theClass ifNil: [self inform: 'You must select a class before giving it a comment.'. ^ false]. theClass comment: aText. ^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. self inform:'You cannot change the current selection'. ^false ! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'ar 8/2/2003 21:00'! removeMessage | messageName | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. (self selectedClass confirmRemovalOf: messageName) ifFalse: [^ false]. self selectedClassOrMetaClass removeMethod: self selectedMessageName. self messageListIndex: 0. self setClassOrganizer. "In case organization not cached" self changed: #messageList! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'dew 9/22/2001 23:06'! selectedBytecodes "Compile the source code for the selected message selector and extract and return the bytecode listing." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. contents _ class sourceCodeAt: selector. contents _ Compiler new parse: contents in: class notifying: nil. contents _ contents generate: #(0 0 0 0). ^ contents symbolic asText! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'sw 11/13/2001 08:41'! selectedMessage "Answer a copy of the source code for the selected message selector." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. contents _ class sourceCodeAt: selector. Preferences browseWithPrettyPrint ifTrue: [contents _ Compiler new format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. self showingAnyKindOfDiffs ifTrue: [contents _ self methodDiffFor: contents class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated]. ^ contents asText makeSelectorBoldIn: class! ! !FileContentsBrowser methodsFor: 'diffs' stamp: 'sw 5/20/2001 21:03'! methodDiffFor: aString class: aPseudoClass selector: selector meta: meta "Answer the diff between the current copy of the given class/selector/meta for the string provided" | theClass source | theClass _ Smalltalk at: aPseudoClass name ifAbsent: [^ aString copy]. meta ifTrue: [theClass _ theClass class]. (theClass includesSelector: selector) ifFalse: [^ aString copy]. source _ theClass sourceCodeAt: selector. ^ Cursor wait showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString inClass: theClass prettyDiffs: self showingPrettyDiffs]! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:48'! fileIntoNewChangeSet | p ff | (p _ self selectedPackage) ifNil: [^ Beeper beep]. ff _ FileStream readOnlyFileNamed: p fullPackageName. ChangeSorter newChangesFromStream: ff named: p packageName! ! !FileContentsBrowser methodsFor: 'infoView' stamp: 'sw 10/7/2004 23:13'! infoViewContents "Answer the string to show in the info view" | theClass stamp exists | editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage]. self selectedClass isNil ifTrue: [^ '']. theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: []. editSelection == #editClass ifTrue: [^ theClass notNil ifTrue: ['Class exists already in the system' translated] ifFalse: ['New class' translated]]. editSelection == #editMessage ifFalse: [^ '']. (theClass notNil and: [self metaClassIndicated]) ifTrue: [theClass _ theClass class]. stamp _ self selectedClassOrMetaClass stampAt: self selectedMessageName. exists _ theClass notNil and: [theClass includesSelector: self selectedMessageName]. ^ stamp = 'methodWasRemoved' ifTrue: [exists ifTrue: ['Existing method removed by this change-set' translated] ifFalse: ['Removal request for a method that is not present in this image' translated]] ifFalse: [stamp, ' · ', (exists ifTrue: ['Method already exists' translated , self extraInfo] ifFalse: ['New method' translated])]! ! !FileContentsBrowser methodsFor: 'metaclass' stamp: 'asm 10/6/2003 11:29'! selectedClassOrMetaClass "Answer the selected class or metaclass." | cls | self metaClassIndicated ifTrue: [^ (cls _ self selectedClass) ifNotNil: [cls metaClass]] ifFalse: [^ self selectedClass]! ! !FileContentsBrowser methodsFor: 'other' stamp: 'bkv 8/13/2003 23:59'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Do nothing if no message is selected." messageListIndex ~= 0 ifTrue: [self systemNavigation browseAllCallsOn: self selectedMessageName]! ! !FileContentsBrowser methodsFor: 'other' stamp: 'dew 9/20/2001 19:03'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | (selector _ self selectedMessageName) ifNotNil: [class _ self selectedClassOrMetaClass. (class exists and: [class realClass includesSelector: selector]) ifTrue: [VersionsBrowser browseVersionsOf: (class realClass compiledMethodAt: selector) class: class realClass theNonMetaClass meta: class realClass isMeta category: self selectedMessageCategoryName selector: selector]]! ! !FileContentsBrowser methodsFor: 'other' stamp: 'asm 5/30/2003 18:11'! didCodeChangeElsewhere "Determine whether the code for the currently selected method and class has been changed somewhere else." | aClass | (aClass _ self selectedClassOrMetaClass) ifNil: [^ false]. (aClass isKindOf: PseudoClass) ifTrue: [^ false]. "class not installed" ^super didCodeChangeElsewhere! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/1/2001 11:16'! labelString "Answer the string for the window title" ^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'tween 8/27/2004 12:05'! addLowerPanesTo: window at: nominalFractions with: editString | verticalOffset row codePane infoPane infoHeight divider | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 1; borderColor: Color black; layoutPolicy: ProportionalLayout new. codePane _ MorphicTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. infoPane _ PluggableTextMorph on: self text: #infoViewContents accept: nil readSelection: nil menu: nil. infoPane askBeforeDiscardingEdits: false. verticalOffset _ 0. ">>not with this browser--- at least not yet --- innerFractions _ 0@0 corner: 1@0. verticalOffset _ self addOptionalAnnotationsTo: row at: innerFractions plus: verticalOffset. verticalOffset _ self addOptionalButtonsTo: row at: innerFractions plus: verticalOffset. <<<<" infoHeight _ 20. row addMorph: (codePane borderWidth: 0) fullFrame: ( LayoutFrame fractions: (0@0 corner: 1@1) offsets: (0@verticalOffset corner: 0@infoHeight negated) ). divider _ BorderedSubpaneDividerMorph forTopEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. row addMorph: divider fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@infoHeight negated corner: 0@(1-infoHeight)) ). row addMorph: (infoPane borderWidth: 0; hideScrollBarsIndefinitely) fullFrame: ( LayoutFrame fractions: (0@1 corner: 1@1) offsets: (0@(1-infoHeight) corner: 0@0) ). window addMorph: row frame: nominalFractions. row on: #mouseEnter send: #paneTransition: to: window. row on: #mouseLeave send: #paneTransition: to: window. ! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'tween 8/27/2004 12:06'! createViews "Create a pluggable version of all the views for a Browser, including views and controllers." | hasSingleFile width topView packageListView classListView switchView messageCategoryListView messageListView browserCodeView infoView | contentsSymbol _ self defaultDiffsSymbol. "#showDiffs or #prettyDiffs" Smalltalk isMorphic ifTrue: [^ self openAsMorph]. (hasSingleFile _ self packages size = 1) ifTrue: [width _ 150] ifFalse: [width _ 200]. (topView _ StandardSystemView new) model: self; borderWidth: 1. "label and minSize taken care of by caller" hasSingleFile ifTrue: [ self systemCategoryListIndex: 1. packageListView _ PluggableListView on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #packageListMenu: keystroke: #packageListKey:from:. packageListView window: (0 @ 0 extent: width @ 12)] ifFalse: [ packageListView _ PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #packageListMenu: keystroke: #packageListKey:from:. packageListView window: (0 @ 0 extent: 50 @ 70)]. topView addSubView: packageListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 50 @ 62). hasSingleFile ifTrue: [topView addSubView: classListView below: packageListView] ifFalse: [topView addSubView: classListView toRightOf: packageListView]. switchView _ self buildInstanceClassSwitchView. switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageCategoryListView _ PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. messageListView _ PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. browserCodeView _ MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: width@110). topView addSubView: browserCodeView below: (hasSingleFile ifTrue: [switchView] ifFalse: [packageListView]). infoView _ StringHolderView new model: self infoString; window: (0@0 extent: width@12); borderWidth: 1. topView addSubView: infoView below: browserCodeView. ^ topView ! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'nk 4/28/2004 10:18'! openAsMorph "Create a pluggable version of all the views for a Browser, including views and controllers." | window aListExtent next mySingletonList | window _ (SystemWindow labelled: 'later') model: self. self packages size = 1 ifTrue: [ aListExtent _ 0.333333 @ 0.34. self systemCategoryListIndex: 1. mySingletonList _ PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #packageListMenu: keystroke: #packageListKey:from:. mySingletonList hideScrollBarsIndefinitely. window addMorph: mySingletonList frame: (0@0 extent: 1.0@0.06). next := 0@0.06] ifFalse: [ aListExtent _ 0.25 @ 0.4. window addMorph: (PluggableListMorph on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #packageListMenu: keystroke: #packageListKey:from:) frame: (0@0 extent: aListExtent). next := aListExtent x @ 0]. self addClassAndSwitchesTo: window at: (next extent: aListExtent) plus: 0. next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (next extent: aListExtent). next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu: keystroke: #messageListKey:from:) frame: (next extent: aListExtent). self addLowerPanesTo: window at: (0@0.4 corner: 1@1) with: nil. ^ window ! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'tpr 3/11/2001 21:26'! classListMenu: aMenu shifted: ignored "Answer the class list menu, ignoring the state of the shift key in this case" ^ self classListMenu: aMenu! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/13/2001 09:12'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane. For the file-contents browser, the choices are restricted to source and the two diffing options" ^ self sourceAndDiffsQuintsOnly! ! !FileContentsBrowser methodsFor: 'initialize-release' stamp: 'dew 9/15/2001 16:19'! defaultBrowserTitle ^ 'File Contents Browser'! ! !FileContentsBrowser commentStamp: '' prior: 0! I am a class browser view on a fileout (either a source file (.st) or change set (.cs)). I do not actually load the code into to the system, nor do I alter the classes in the image. Use me to vet code in a comfortable way before loading it into your image. From a FileList, I can be invoked by selecting a source file and selecting the "browse code" menu item from the yellow button menu. I use PseudoClass, PseudoClassOrganizers, and PseudoMetaclass to model the class structure of the source file.! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'yo 7/5/2004 22:32'! browseCompressedCodeStream: aStandardFileStream "Browse the selected file in fileIn format." | zipped unzipped | zipped _ GZipReadStream on: aStandardFileStream. unzipped _ MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. self browseStream: unzipped named: aStandardFileStream name.! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nb 6/17/2003 12:25'! browseFile: aFilename "Open a file contents browser on a file of the given name" aFilename ifNil: [^ Beeper beep]. self browseFiles: (Array with: aFilename)! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'nk 2/17/2004 19:26'! browseStream: aStream self browseStream: aStream named: aStream name! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'yo 8/17/2004 10:17'! browseStream: aStream named: aString | package organizer packageDict browser | Cursor wait showWhile: [ packageDict _ Dictionary new. organizer _ SystemOrganizer defaultList: Array new. (aStream respondsTo: #converter:) ifTrue: [ aStream setConverterForCode. ]. package _ (FilePackage new fullName: aString; fileInFrom: aStream). packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName. (browser := self new) systemOrganizer: organizer; packages: packageDict]. self openBrowserView: browser createViews label: 'File Contents Browser'. ! ! !FileContentsBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:25'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'File Contents Browser' brightColor: #tan pastelColor: #paleTan helpMessage: 'Lets you view the contents of a file as code, in a browser-like tool.'! ! !FileContentsBrowser class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 18:17'! initialize FileList registerFileReader: self! ! !FileContentsBrowser class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'! fileReaderServicesForDirectory: aDirectory ^{ self serviceBrowseCodeFiles }! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 2/17/2004 19:18'! fileReaderServicesForFile: fullName suffix: suffix ((FileStream isSourceFileSuffix: suffix) or: [ suffix = '*' ]) ifTrue: [ ^Array with: self serviceBrowseCode]. ^(fullName endsWith: 'cs.gz') ifTrue: [ Array with: self serviceBrowseCompressedCode ] ifFalse: [#()] ! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/22/2004 18:25'! selectAndBrowseFile: aFileList "When no file are selected you can ask to browse several of them" | selectionPattern files | selectionPattern := FillInTheBlank request:'What files?' initialAnswer: '*.cs;*.st'. files _ (aFileList directory fileNamesMatching: selectionPattern) collect: [:each | aFileList directory fullNameFor: each]. self browseFiles: files. ! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'! serviceBrowseCode "Answer the service of opening a file-contents browser" ^ (SimpleServiceEntry provider: self label: 'code-file browser' selector: #browseStream: description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' buttonLabel: 'code') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:35'! serviceBrowseCodeFiles ^ (SimpleServiceEntry provider: self label: 'browse code files' selector: #selectAndBrowseFile:) argumentGetter: [ :fileList | fileList ]; yourself! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'nk 4/29/2004 10:35'! serviceBrowseCompressedCode "Answer a service for opening a changelist browser on a file" ^ (SimpleServiceEntry provider: self label: 'code-file browser' selector: #browseCompressedCodeStream: description: 'open a "file-contents browser" on this file, allowing you to view and selectively load its code' buttonLabel: 'code') argumentGetter: [ :fileList | fileList readOnlyStream ]! ! !FileContentsBrowser class methodsFor: 'file list services' stamp: 'md 11/23/2004 13:34'! services "Answer potential file services associated with this class" ^ {self serviceBrowseCode}.! ! !FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! fullPathFor: path ^path isEmpty ifTrue:[pathName asSqueakPathName] ifFalse:[path]! ! !FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! pathName "Return the path from the root of the file system to this directory." ^ pathName asSqueakPathName. ! ! !FileDirectory methodsFor: 'path access' stamp: 'yo 12/19/2003 21:15'! pathParts "Return the path from the root of the file system to this directory as an array of directory names." ^ pathName asSqueakPathName findTokens: self pathNameDelimiter asString! ! !FileDirectory methodsFor: 'file stream creation' stamp: 'tpr 10/13/2003 12:34'! oldFileOrNoneNamed: fileName "If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil." ^ FileStream oldFileOrNoneNamed: fileName ! ! !FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! containingDirectory "Return the directory containing this directory." ^ FileDirectory on: (FileDirectory dirPathFor: pathName asSqueakPathName) ! ! !FileDirectory methodsFor: 'enumeration' stamp: 'nk 2/23/2001 11:35'! directoryEntry ^self containingDirectory entryAt: self localName! ! !FileDirectory methodsFor: 'enumeration' stamp: 'tpr 10/13/2003 10:58'! directoryEntryFor: filenameOrPath "Answer the directory entry for the given file or path. Sorta like a poor man's stat()." | fName dir | DirectoryClass splitName: filenameOrPath to:[:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. self isCaseSensitive ifTrue:[^dir entries detect:[:entry| entry name = fName] ifNone:[nil]] ifFalse:[^dir entries detect:[:entry| entry name sameAs: fName] ifNone:[nil]]! ! !FileDirectory methodsFor: 'enumeration' stamp: 'jm 12/5/97 12:23'! entries "Return a collection of directory entries for the files and directories in this directory. Each entry is a five-element array: (). See primLookupEntryIn:index: for further details." "FileDirectory default entries" ^ self directoryContentsFor: pathName ! ! !FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! fullName "Return the full name of this directory." ^pathName asSqueakPathName ! ! !FileDirectory methodsFor: 'enumeration' stamp: 'yo 12/19/2003 21:15'! localName "Return the local name of this directory." ^FileDirectory localNameFor: pathName asSqueakPathName! ! !FileDirectory methodsFor: 'enumeration' stamp: 'mir 8/24/2001 12:01'! matchingEntries: criteria "Ignore the filter criteria for now" ^self entries! ! !FileDirectory methodsFor: 'enumeration' stamp: 'wod 6/16/1998 15:07'! statsForDirectoryTree: rootedPathName "Return the size statistics for the entire directory tree starting at the given root. The result is a three element array of the form: (). This method also serves as an example of how recursively enumerate a directory tree." "wod 6/16/1998: add Cursor wait, and use 'self pathNameDelimiter asString' rather than hardwired ':' " "FileDirectory default statsForDirectoryTree: '\smalltalk'" | dirs files bytes todo p entries | Cursor wait showWhile: [ dirs _ files _ bytes _ 0. todo _ OrderedCollection with: rootedPathName. [todo isEmpty] whileFalse: [ p _ todo removeFirst. entries _ self directoryContentsFor: p. entries do: [:entry | (entry at: 4) ifTrue: [ todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)). dirs _ dirs + 1] ifFalse: [ files _ files + 1. bytes _ bytes + (entry at: 5)]]]]. ^ Array with: dirs with: files with: bytes ! ! !FileDirectory methodsFor: 'enumeration' stamp: 'nk 6/12/2004 12:39'! withAllSubdirectoriesCollect: aBlock "Evaluate aBlock with each of the directories in the subtree of the file system whose root is this directory. Answer the results of these evaluations." | result todo dir | result _ OrderedCollection new: 100. todo _ OrderedCollection with: self. [todo size > 0] whileTrue: [ dir _ todo removeFirst. result add: (aBlock value: dir). dir directoryNames do: [:n | todo add: (dir directoryNamed: n)]]. ^ result ! ! !FileDirectory methodsFor: 'testing' stamp: 'mir 6/25/2001 13:08'! acceptsUploads ^true! ! !FileDirectory methodsFor: 'testing' stamp: 'tpr 2/17/2004 19:56'! directoryExists: filenameOrPath "Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory." "FileDirectory default directoryExists: FileDirectory default pathName" | fName dir | DirectoryClass splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ self directoryNamed: filePath]]. ^dir exists and: [ self isCaseSensitive ifTrue:[dir directoryNames includes: fName] ifFalse:[dir directoryNames anySatisfy: [:name| name sameAs: fName]]]. ! ! !FileDirectory methodsFor: 'testing' stamp: 'yo 2/24/2005 18:34'! exists "Answer whether the directory exists" | result | result _ self primLookupEntryIn: pathName asVmPathName index: 1. ^ result ~= #badDirectoryPath ! ! !FileDirectory methodsFor: 'testing' stamp: 'tpr 10/13/2003 10:59'! fileExists: filenameOrPath "Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory." "FileDirectory default fileExists: Smalltalk sourcesName" | fName dir | DirectoryClass splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. self isCaseSensitive ifTrue:[^dir fileNames includes: fName] ifFalse:[^dir fileNames anySatisfy: [:name| name sameAs: fName]]. ! ! !FileDirectory methodsFor: 'testing' stamp: 'ar 5/30/2001 21:42'! isAFileNamed: fName ^FileStream isAFileNamed: (self fullNameFor: fName)! ! !FileDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 10:46'! isRemoteDirectory "answer whatever the receiver is a remote directory" ^ false! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'! createDirectory: localFileName "Create a directory with the given name in this directory. Fail if the name is bad or if a file or directory with that name already exists." self primCreateDirectory: (self fullNameFor: localFileName) asVmPathName ! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:33'! deleteDirectory: localDirName "Delete the directory with the given name in this directory. Fail if the path is bad or if a directory by that name does not exist." self primDeleteDirectory: (self fullNameFor: localDirName) asVmPathName. ! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'! deleteFileNamed: localFileName ifAbsent: failBlock "Delete the file of the given name if it exists, else evaluate failBlock. If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53" | fullName | fullName _ self fullNameFor: localFileName. (StandardFileStream retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName) asVmPathName] until:[:result| result notNil] forFileNamed: fullName) == nil ifTrue: [^failBlock value]. ! ! !FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 16:48'! deleteLocalFiles "Delete the local files in this directory." self fileNames do:[:fn| self deleteFileNamed: fn ifAbsent: [(CannotDeleteFileException new messageText: 'Could not delete the old version of file ' , (self fullNameFor: fn)) signal]] ! ! !FileDirectory methodsFor: 'file operations' stamp: 'tpr 10/13/2003 10:59'! fileOrDirectoryExists: filenameOrPath "Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory." "FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName" | fName dir | DirectoryClass splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. ^ (dir includesKey: fName) or: [ fName = '' and:[ dir entries size > 1]]! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'! getMacFileTypeAndCreator: fileName | results typeString creatorString | "get the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)." "FileDirectory default getMacFileNamed: 'foo'" typeString _ ByteArray new: 4 withAll: ($? asInteger). creatorString _ ByteArray new: 4 withAll: ($? asInteger). [self primGetMacFileNamed: (self fullNameFor: fileName) asVmPathName type: typeString creator: creatorString.] ensure: [typeString _ typeString asString. creatorString _ creatorString asString]. results _ Array with: typeString convertFromSystemString with: creatorString convertFromSystemString. ^results ! ! !FileDirectory methodsFor: 'file operations' stamp: 'ar 4/24/2001 16:31'! mimeTypesFor: fileName "Return a list of MIME types applicable to the receiver. This default implementation uses the file name extension to figure out what we're looking at but specific subclasses may use other means of figuring out what the type of some file is. Some systems like the macintosh use meta data on the file to indicate data type" | idx ext dot | ext _ ''. dot _ self class extensionDelimiter. idx _ (self fullNameFor: fileName) findLast: [:ch| ch = dot]. idx = 0 ifFalse:[ext _ fileName copyFrom: idx+1 to: fileName size]. ^StandardMIMEMappings at: ext asLowercase ifAbsent:[nil]! ! !FileDirectory methodsFor: 'file operations' stamp: 'tpr 3/26/2002 18:09'! recursiveDelete "Delete the this directory, recursing down its tree." self directoryNames do: [:dn | (self directoryNamed: dn) recursiveDelete]. self deleteLocalFiles. "should really be some exception handling for directory deletion, but no support for it yet" self containingDirectory deleteDirectory: self localName! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'! rename: oldFileName toBe: newFileName | selection oldName newName | "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name." "Modified for retry after GC ar 3/21/98 18:09" oldName _ self fullNameFor: oldFileName. newName _ self fullNameFor: newFileName. (StandardFileStream retryWithGC:[self primRename: oldName asVmPathName to: newName asVmPathName] until:[:result| result notNil] forFileNamed: oldName) ~~ nil ifTrue:[^self]. (self fileExists: oldFileName) ifFalse:[ ^self error:'Attempt to rename a non-existent file'. ]. (self fileExists: newFileName) ifTrue:[ selection _ (PopUpMenu labels: 'delete old version cancel') startUpWithCaption: 'Trying to rename a file to be ', newFileName , ' and it already exists.'. selection = 1 ifTrue: [self deleteFileNamed: newFileName. ^ self rename: oldFileName toBe: newFileName]]. ^self error:'Failed to rename file'.! ! !FileDirectory methodsFor: 'file operations' stamp: 'yo 2/24/2005 18:34'! setMacFileNamed: fileName type: typeString creator: creatorString "Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4. Does nothing on other platforms (where the underlying primitive is a noop)." "FileDirectory default setMacFileNamed: 'foo' type: 'TEXT' creator: 'ttxt'" self primSetMacFileNamed: (self fullNameFor: fileName) asVmPathName type: typeString convertToSystemString creator: creatorString convertToSystemString. ! ! !FileDirectory methodsFor: 'file operations' stamp: 'mir 10/8/2004 08:51'! upLoadProject: projectFile named: destinationFileName resourceUrl: resUrl retry: aBool "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem. No retrying for local file systems." | result | result _ self putFile: projectFile named: destinationFileName. [self setMacFileNamed: destinationFileName type: 'SOBJ' creator: 'FAST'] on: Error do: [ "ignore" ]. ^result! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'gk 2/10/2004 13:22'! asUrl "Convert my path into a file:// type url - a FileUrl." ^FileUrl pathParts: (self pathParts copyWith: '')! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'nk 6/22/2004 18:25'! fileNamesMatching: pat " FileDirectory default fileNamesMatching: '*' FileDirectory default fileNamesMatching: '*.image;*.changes' " | files | files _ OrderedCollection new. (pat findTokens: ';', String crlf) do: [ :tok | files addAll: (self fileNames select: [:name | tok match: name]) ]. ^files ! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'tpr 10/13/2003 10:59'! fullNameFor: fileName "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." "Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm. Also note that this method is tolerent of a nil argument -- is simply returns nil in this case." | correctedLocalName prefix | fileName ifNil: [^ nil]. DirectoryClass splitName: fileName to: [:filePath :localName | correctedLocalName _ localName isEmpty ifFalse: [self checkName: localName fixErrors: true] ifTrue: [localName]. prefix _ self fullPathFor: filePath]. prefix isEmpty ifTrue: [^correctedLocalName]. prefix last = self pathNameDelimiter ifTrue:[^ prefix, correctedLocalName] ifFalse:[^ prefix, self slash, correctedLocalName]! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 22:23'! isTypeFile ^true! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'gh 1/22/2002 15:45'! lastNameFor: baseFileName extension: extension "Assumes a file name includes a version number encoded as '.' followed by digits preceding the file extension. Increment the version number and answer the new file name. If a version number is not found, set the version to 1 and answer a new file name" | files splits | files _ self fileNamesMatching: (baseFileName,'*', self class dot, extension). splits _ files collect: [:file | self splitNameVersionExtensionFor: file] thenSelect: [:split | (split at: 1) = baseFileName]. splits _ splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)]. ^splits isEmpty ifTrue: [nil] ifFalse: [(baseFileName, '.', (splits last at: 2) asString, self class dot, extension) asFileName]! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'ar 2/27/2001 18:56'! realUrl "Senders expect url without trailing slash - #url returns slash" | url | url _ self url. url last = $/ ifTrue:[^url copyFrom: 1 to: url size-1]. ^url! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'yo 12/19/2003 21:15'! relativeNameFor: aFileName "Return the full name for aFileName, assuming that aFileName is a name relative to me." aFileName isEmpty ifTrue: [ ^pathName asSqueakPathName]. ^aFileName first = self pathNameDelimiter ifTrue: [ pathName asSqueakPathName, aFileName ] ifFalse: [ pathName asSqueakPathName, self slash, aFileName ] ! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'gk 2/10/2004 13:23'! url "Convert my path into a file:// type url String." ^self asUrl toText! ! !FileDirectory methodsFor: 'printing' stamp: 'yo 12/19/2003 21:15'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: self class name. aStream nextPutAll: ' on '. pathName asSqueakPathName printOn: aStream. ! ! !FileDirectory methodsFor: 'private' stamp: 'yo 2/24/2005 18:34'! directoryContentsFor: fullPath "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." "FileDirectory default directoryContentsFor: ''" | entries index done entryArray f | entries _ OrderedCollection new: 200. index _ 1. done _ false. f _ fullPath asVmPathName. [done] whileFalse: [ entryArray _ self primLookupEntryIn: f index: index. #badDirectoryPath = entryArray ifTrue: [ ^(InvalidDirectoryError pathName: pathName asSqueakPathName) signal]. entryArray == nil ifTrue: [done _ true] ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)]. index _ index + 1]. ^ entries asArray collect: [:s | s convertFromSystemName]. ! ! !FileDirectory methodsFor: 'private' stamp: 'yo 12/19/2003 18:30'! setPathName: pathString pathName _ FilePath pathName: pathString. ! ! !FileDirectory methodsFor: 'private' stamp: 'mir 6/25/2001 18:05'! storeServerEntryOn: stream stream nextPutAll: 'name:'; tab; nextPutAll: self localName; cr; nextPutAll: 'directory:'; tab; nextPutAll: self pathName; cr; nextPutAll: 'type:'; tab; nextPutAll: 'file'; cr! ! !FileDirectory methodsFor: 'file directory' stamp: 'hg 2/2/2002 16:37'! assureExistence "Make sure the current directory exists. If necessary, create all parts in between" self containingDirectory assureExistenceOfPath: self localName! ! !FileDirectory methodsFor: 'file directory' stamp: 'tetha 3/28/2004 19:38'! assureExistenceOfPath: lPath "Make sure the local directory exists. If necessary, create all parts in between" | localPath | localPath _ lPath. localPath isEmpty ifTrue: [ ^self ]. "Assumed to exist" (self directoryExists: localPath) ifTrue: [^ self]. "exists" "otherwise check parent first and then create local dir" self containingDirectory assureExistenceOfPath: self localName. self createDirectory: localPath! ! !FileDirectory methodsFor: 'squeaklets' stamp: 'mir 6/17/2001 23:42'! downloadUrl ^''! ! !FileDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/23/2003 16:21'! writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory "write aProject (a file version can be found in the file named fileNameString in localDirectory)" aProject writeFileNamed: fileNameString fromDirectory: localDirectory toServer: self! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:09'! eToyBaseFolderSpec ^ServerDirectory eToyBaseFolderSpecForFileDirectory: self! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:09'! eToyBaseFolderSpec: aString ^ServerDirectory eToyBaseFolderSpecForFileDirectory: self put: aString! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:44'! eToyUserList | spec index fd list match | spec _ self eToyBaseFolderSpec. "something like 'U:\Squeak\users\*-Squeak'." spec ifNil:[^ServerDirectory eToyUserListForFileDirectory: self]. "Compute list of users based on base folder spec" index _ spec indexOf: $*. "we really need one" index = 0 ifTrue:[^ServerDirectory eToyUserListForFileDirectory: self]. fd _ FileDirectory on: (FileDirectory dirPathFor: (spec copyFrom: 1 to: index)). "reject all non-directories" list _ fd entries select:[:each| each isDirectory]. "reject all non-matching entries" match _ spec copyFrom: fd pathName size + 2 to: spec size. list _ list collect:[:each| each name]. list _ list select:[:each| match match: each]. "extract the names (e.g., those positions that match '*')" index _ match indexOf: $*. list _ list collect:[:each| each copyFrom: index to: each size - (match size - index)]. ^list! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 15:41'! eToyUserListUrl ^ServerDirectory eToyUserListUrlForFileDirectory: self! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 15:48'! eToyUserListUrl: urlString ^ServerDirectory eToyUserListUrlForFileDirectory: self put: urlString.! ! !FileDirectory methodsFor: 'school support' stamp: 'yo 12/19/2003 19:09'! eToyUserName: aString "Set the default directory from the given user name" | dirName | dirName _ self eToyBaseFolderSpec. "something like 'U:\Squeak\users\*-Squeak'" dirName ifNil:[^self]. dirName _ dirName copyReplaceAll:'*' with: aString. " dirName last = self class pathNameDelimiter ifFalse:[dirName _ dirName, self slash]. FileDirectory setDefaultDirectoryFrom: dirName. dirName _ dirName copyFrom: 1 to: dirName size - 1. " pathName _ FilePath pathName: dirName! ! !FileDirectory methodsFor: 'school support' stamp: 'ar 9/5/2001 16:13'! hasEToyUserList ^self eToyUserListUrl notNil or:[self eToyBaseFolderSpec notNil]! ! !FileDirectory methodsFor: '*Croquet' stamp: 'ar 10/13/2004 17:54'! pathFromUrl: aFileUrl | first | ^String streamContents: [ :s | first := false. aFileUrl path do: [ :p | first ifTrue: [ s nextPut: self pathNameDelimiter ]. first _ true. s nextPutAll: p ] ].! ! !FileDirectory class methodsFor: 'instance creation' stamp: 'tpr 10/13/2003 10:49'! on: pathString "Return a new file directory for the given path, of the appropriate FileDirectory subclass for the current OS platform." | pathName | DirectoryClass ifNil: [self setDefaultDirectoryClass]. "If path ends with a delimiter (: or /) then remove it" ((pathName _ pathString) endsWith: self pathNameDelimiter asString) ifTrue: [ pathName _ pathName copyFrom: 1 to: pathName size - 1]. ^ DirectoryClass new setPathName: pathName ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 3/6/2004 20:18'! baseNameFor: fileName "Return the given file name without its extension, if any. We have to remember that many (most?) OSs allow extension separators within directory names and so the leaf filename needs to be extracted, trimmed and rejoined. Yuck" "The test is FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim.blam') should end 'foo.bar/blim' (or as appropriate for your platform AND FileDirectory baseNameFor: ((FileDirectory default directoryNamed: 'foo.bar') fullNameFor:'blim') should be the same and NOT 'foo' Oh, and FileDirectory baseNameFor: 'foo.bar' should be 'foo' not '/foo' " | delim i leaf | self splitName: fileName to: [:path : fn| delim _ DirectoryClass extensionDelimiter. i _ fn findLast: [:c | c = delim]. leaf _ i = 0 ifTrue: [fn] ifFalse: [fn copyFrom: 1 to: i - 1]. path isEmpty ifTrue:[^leaf]. ^path, self slash, leaf] ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'jf 2/7/2004 17:22'! checkName: fileName fixErrors: flag "Check a string fileName for validity as a file name on the current default file system. Answer the original file name if it is valid. If the name is not valid (e.g., it is too long or contains illegal characters) and fixing is false, raise an error. If fixing is true, fix the name (usually by truncating and/or tranforming characters), and answer the corrected name. The default behavior is to truncate the name to 31 chars. Subclasses can do any kind of checking and correction appropriate to the underlying platform." ^ DefaultDirectory checkName: fileName fixErrors: flag ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'! dirPathFor: fullName "Return the directory part the given name." DirectoryClass splitName: fullName to: [:dirPath :localName | ^ dirPath]! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'ar 4/7/2002 15:47'! directoryEntryFor: filenameOrPath ^self default directoryEntryFor: filenameOrPath! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 10:59'! localNameFor: fullName "Return the local part the given name." DirectoryClass splitName: fullName to: [:dirPath :localName | ^ localName]! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 12/15/2003 12:03'! startUp "Establish the platform-specific FileDirectory subclass. Do any platform-specific startup." self setDefaultDirectoryClass. self setDefaultDirectory: (self dirPathFor: SmalltalkImage current imageName). Preferences startInUntrustedDirectory ifTrue:[ "The SecurityManager may override the default directory to prevent unwanted write access etc." self setDefaultDirectory: SecurityManager default untrustedUserDirectory. "Make sure we have a place to go to" DefaultDirectory assureExistence]. SmalltalkImage current openSourceFiles. ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'tpr 10/13/2003 11:00'! urlForFileNamed: aFilename "Create a URL for the given fully qualified file name" "FileDirectory urlForFileNamed: 'C:\Home\andreasr\Squeak\DSqueak3\DSqueak3_1.1\DSqueak3.1.image' " | path localName | DirectoryClass splitName: aFilename to: [:p :n | path _ p. localName _ n]. ^ localName asUrlRelativeTo: (self on: path) url asUrl! ! !FileDirectory class methodsFor: 'create/delete file' stamp: 'sd 9/30/2003 14:01'! lookInUsualPlaces: fileName "Check the default directory, the imagePath, and the vmPath (and the vmPath's owner) for this file." | vmp | (FileDirectory default fileExists: fileName) ifTrue: [^ FileDirectory default fileNamed: fileName]. ((vmp _ FileDirectory on: SmalltalkImage current imagePath) fileExists: fileName) ifTrue: [^ vmp fileNamed: fileName]. ((vmp _ FileDirectory on: SmalltalkImage current vmPath) fileExists: fileName) ifTrue: [^ vmp fileNamed: fileName]. ((vmp _ vmp containingDirectory) fileExists: fileName) ifTrue: [^ vmp fileNamed: fileName]. ^ nil! ! !FileDirectory class methodsFor: 'system start up' stamp: 'tpr 10/9/2003 16:27'! openChanges: changesName forImage: imageName "find the changes file by looking in a) the directory derived from the image name b) the DefaultDirectory (which will normally be the directory derived from the image name or the SecurityManager's choice) If an old file is not found in either place, check for a read-only file in the same places. If that fails, return nil" | changes fd | "look for the changes file or an alias to it in the image directory" fd _ FileDirectory on: (FileDirectory dirPathFor: imageName). (fd fileExists: changesName) ifTrue: [changes _ fd oldFileNamed: changesName]. changes ifNotNil:[^changes]. "look for the changes in the default directory" fd _ DefaultDirectory. (fd fileExists: changesName) ifTrue: [changes _ fd oldFileNamed: changesName]. changes ifNotNil:[^changes]. "look for read-only changes in the image directory" fd _ FileDirectory on: (FileDirectory dirPathFor: imageName). (fd fileExists: changesName) ifTrue: [changes _ fd readOnlyFileNamed: changesName]. changes ifNotNil:[^changes]. "look for read-only changes in the default directory" fd _ DefaultDirectory. (fd fileExists: changesName) ifTrue: [changes _ fd readOnlyFileNamed: changesName]. "this may be nil if the last try above failed to open a file" ^changes ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'tpr 12/15/2003 12:02'! openSources: sourcesName andChanges: changesName forImage: imageName "Open the changes and sources files and install them in SourceFiles. Inform the user of problems regarding write permissions or CR/CRLF mixups." "Note: SourcesName and imageName are full paths; changesName is a local name." | sources changes msg wmsg | msg _ 'Squeak cannot locate &fileRef. Please check that the file is named properly and is in the same directory as this image. Further explanation can found in the startup window, ''How Squeak Finds Source Code''.'. wmsg _ 'Squeak cannot write to &fileRef. Please check that you have write permission for this file. You won''t be able to save this image correctly until you fix this.'. sources _ self openSources: sourcesName forImage: imageName. changes _ self openChanges: changesName forImage: imageName. ((sources == nil or: [sources atEnd]) and: [Preferences valueOfFlag: #warnIfNoSourcesFile]) ifTrue: [SmalltalkImage current platformName = 'Mac OS' ifTrue: [msg _ msg , ' Make sure the sources file is not an Alias.']. self inform: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName)]. (changes == nil and: [Preferences valueOfFlag: #warnIfNoChangesFile]) ifTrue: [self inform: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. ((Preferences valueOfFlag: #warnIfNoChangesFile) and: [changes notNil]) ifTrue: [changes isReadOnly ifTrue: [self inform: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. ((changes next: 200) includesSubString: String crlf) ifTrue: [self inform: 'The changes file named ' , changesName , ' has been injured by an unpacking utility. Crs were changed to CrLfs. Please set the preferences in your decompressing program to "do not convert text files" and unpack the system again.']]. SourceFiles _ Array with: sources with: changes! ! !FileDirectory class methodsFor: 'system start up' stamp: 'tpr 2/17/2004 19:59'! openSources: fullSourcesName forImage: imageName "We first do a check to see if a compressed version ofthe sources file is present. Open the .sources file read-only after searching in: a) the directory where the VM lives b) the directory where the image came from c) the DefaultDirectory (which is likely the same as b unless the SecurityManager has changed it). " | sources fd sourcesName | (fullSourcesName endsWith: 'sources') ifTrue: ["Look first for a sources file in compressed format." sources _ self openSources: (fullSourcesName allButLast: 7) , 'stc' forImage: imageName. sources ifNotNil: [^ CompressedSourceStream on: sources]]. sourcesName _ FileDirectory localNameFor: fullSourcesName. "look for the sources file or an alias to it in the VM's directory" fd _ FileDirectory on: SmalltalkImage current vmPath. (fd fileExists: sourcesName) ifTrue: [sources _ fd readOnlyFileNamed: sourcesName]. sources ifNotNil: [^ sources]. "look for the sources file or an alias to it in the image directory" fd _ FileDirectory on: (FileDirectory dirPathFor: imageName). (fd fileExists: sourcesName) ifTrue: [sources _ fd readOnlyFileNamed: sourcesName]. sources ifNotNil: [^ sources]. "look for the sources in the current directory" fd _ DefaultDirectory. (fd fileExists: sourcesName) ifTrue: [sources _ fd readOnlyFileNamed: sourcesName]. "sources may still be nil here" ^sources ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'tak 12/17/2004 14:03'! setDefaultDirectory: directoryName "Initialize the default directory to the directory supplied. This method is called when the image starts up." | dirName | DirectoryClass _ self activeDirectoryClass. dirName _ (FilePath pathName: directoryName) asSqueakPathName. [dirName endsWith: self slash] whileTrue:[ dirName _ dirName copyFrom: 1 to: dirName size - self slash size. ]. DefaultDirectory _ self on: dirName.! ! !FileDirectory class methodsFor: 'system start up' stamp: 'tpr 10/13/2003 10:39'! setDefaultDirectoryClass "Initialize the default directory class to suit this platform. This method is called when the image starts up - it needs to be right at the front of the list of the startup sequence" DirectoryClass _ self activeDirectoryClass ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'yo 3/22/2004 15:01'! setDefaultDirectoryFrom: imageName "Initialize the default directory to the directory containing the Squeak image file. This method is called when the image starts up." DirectoryClass _ self activeDirectoryClass. DefaultDirectory _ self on: (FilePath pathName: (self dirPathFor: imageName) isEncoded: true) asSqueakPathName. ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'sd 11/16/2003 13:13'! shutDown SmalltalkImage current closeSourceFiles. ! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:58'! makeAbsolute: path "Ensure that path looks like an absolute path" ^path first = self pathNameDelimiter ifTrue: [ path ] ifFalse: [ self slash, path ]! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'! makeRelative: path "Ensure that path looks like an relative path" ^path first = self pathNameDelimiter ifTrue: [ path copyWithoutFirst ] ifFalse: [ path ]! ! !FileDirectory class methodsFor: 'class initialization' stamp: 'dgd 3/30/2003 18:27'! initializeStandardMIMETypes "FileDirectory initializeStandardMIMETypes" StandardMIMEMappings _ Dictionary new. #( (gif ('image/gif')) (pdf ('application/pdf')) (aiff ('audio/aiff')) (bmp ('image/bmp')) (png ('image/png')) (swf ('application/x-shockwave-flash')) (htm ('text/html' 'text/plain')) (html ('text/html' 'text/plain')) (jpg ('image/jpeg')) (jpeg ('image/jpeg')) (mid ('audio/midi')) (midi ('audio/midi')) (mp3 ('audio/mpeg')) (mpeg ('video/mpeg')) (mpg ('video/mpg')) (txt ('text/plain')) (text ('text/plain')) (mov ('video/quicktime')) (qt ('video/quicktime')) (tif ('image/tiff')) (tiff ('image/tiff')) (ttf ('application/x-truetypefont')) (wrl ('model/vrml')) (vrml ('model/vrml')) (wav ('audio/wav')) ) do:[:spec| StandardMIMEMappings at: spec first asString put: spec last. ].! ! !FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'nk 11/13/2002 19:39'! deleteDirectory (self myDirectory exists) ifTrue: [self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName]! ! !FileDirectoryTest methodsFor: 'create/delete tests' stamp: 'aka 5/21/2003 00:31'! testDeleteDirectory "Test deletion of a directory" | aContainingDirectory preTestItems | aContainingDirectory _ self myDirectory containingDirectory. preTestItems _ aContainingDirectory fileAndDirectoryNames. self assert: self myAssuredDirectory exists. aContainingDirectory deleteDirectory: self myLocalDirectoryName. self shouldnt: [aContainingDirectory directoryNames includes: self myLocalDirectoryName ] description: 'Should successfully delete directory.'. self should: [preTestItems = aContainingDirectory fileAndDirectoryNames] description: 'Should only delete the indicated directory.'. ! ! !FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:44'! myAssuredDirectory ^self myDirectory assureExistence! ! !FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:42'! myDirectory ^FileDirectory default directoryNamed: self myLocalDirectoryName! ! !FileDirectoryTest methodsFor: 'resources' stamp: 'hg 2/2/2002 16:42'! myLocalDirectoryName ^'zTestDir'! ! !FileDirectoryTest methodsFor: 'resources' stamp: 'nk 11/13/2002 19:56'! tearDown [ self deleteDirectory ] on: Error do: [ :ex | ]! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'aka 5/20/2003 16:43'! testAttemptExistenceCheckWhenFile "How should a FileDirectory instance respond with an existent file name?" | directory | FileDirectory default forceNewFileNamed: 'aTestFile'. directory := FileDirectory default directoryNamed: 'aTestFile'. self shouldnt: [directory exists] description: 'Files are not directories.'.! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'aka 5/20/2003 23:33'! testDirectoryExists self assert: self myAssuredDirectory exists. self should: [self myDirectory containingDirectory directoryExists: self myLocalDirectoryName]. self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName. self shouldnt: [self myDirectory containingDirectory directoryExists: self myLocalDirectoryName]! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'svp 5/20/2003 17:14'! testDirectoryExistsWhenLikeNamedFileExists | testFileName | [testFileName := self myAssuredDirectory fullNameFor: 'zDirExistsTest.testing'. (FileStream newFileNamed: testFileName) close. self should: [FileStream isAFileNamed: testFileName]. self shouldnt: [(FileDirectory on: testFileName) exists]] ensure: [self myAssuredDirectory deleteFileNamed: 'zDirExistsTest.testing'] ! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'hg 2/2/2002 16:44'! testDirectoryNamed self should: [(self myDirectory containingDirectory directoryNamed: self myLocalDirectoryName) pathName = self myDirectory pathName]! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'tpr 8/15/2003 16:30'! testExists self should: [FileDirectory default exists] description: 'Should know default directory exists.'. self should: [self myAssuredDirectory exists] description: 'Should know created directory exists.'. self myDirectory containingDirectory deleteDirectory: self myLocalDirectoryName. self shouldnt: [(self myDirectory containingDirectory directoryNamed: self myLocalDirectoryName) exists] description: 'Should know that recently deleted directory no longer exists.'.! ! !FileDirectoryTest methodsFor: 'existence tests' stamp: 'aka 5/20/2003 14:26'! testNonExistentDirectory | directory parentDirectory | directory _FileDirectory default directoryNamed: 'nonExistentFolder'. self shouldnt: [directory exists] description: 'A FileDirectory instance should know if it points to a non-existent directory.'. parentDirectory _FileDirectory default. self shouldnt: [parentDirectory directoryExists: 'nonExistentFolder'] description: 'A FileDirectory instance should know when a directory of the given name doesn''t exist'. ! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'dgd 8/27/2004 18:45'! asString ^itemName translatedIfCorresponds! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/12/2001 16:20'! contents ^((model directoryNamesFor: item) sortBy: [ :a :b | a caseInsensitiveLessOrEqual: b]) collect: [ :n | FileDirectoryWrapper with: (item directoryNamed: n) name: n model: self ] ! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/12/2001 16:22'! directoryNamesFor: anItem ^model directoryNamesFor: anItem! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'tpr 11/28/2003 14:02'! hasContents "Return whether this directory has subfolders. The value is cached to avoid a performance penalty. Also for performance reasons, the code below will just assume that the directory does indeed have contents in a few of cases: 1. If the item is not a FileDirectory (thus avoiding the cost of refreshing directories that are not local) 2. If it's the root directory of a given volume 3. If there is an error computing the FileDirectory's contents " hasContents ifNil: [hasContents := true. "default" ["Best test I could think of for determining if this is a local directory " ((item isKindOf: FileDirectory) and: ["test to see that it's not the root directory" "there has to be a better way of doing this test -tpr" item pathParts size > 1]) ifTrue: [hasContents := self contents notEmpty]] on: Error do: [hasContents := true]]. ^ hasContents! ! !FileDirectoryWrapper methodsFor: 'as yet unclassified' stamp: 'sps 12/5/2002 16:59'! setItem: anObject name: aString model: aModel item _ anObject. model _ aModel. itemName _ aString. hasContents _ nil. ! ! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:49'! fileClass ^ fileClass ifNil: [StandardFileStream]! ! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:42'! fileClass: aClass fileClass _ aClass! ! !FileExistsException methodsFor: 'exceptionDescription' stamp: 'LC 10/24/2001 21:50'! defaultAction "The default action taken if the exception is signaled." ^ self fileClass fileExistsUserHandling: self fileName ! ! !FileExistsException class methodsFor: 'exceptionInstantiator' stamp: 'LC 10/24/2001 21:50'! fileName: aFileName fileClass: aClass ^ self new fileName: aFileName; fileClass: aClass! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/19/2003 10:08'! acceptDroppingMorph: aTransferMorph event: evt inMorph: dest | oldName oldEntry destDirectory newName newEntry baseName response | destDirectory _ self dropDestinationDirectory: dest event: evt. oldName _ aTransferMorph passenger. baseName _ FileDirectory localNameFor: oldName. newName _ destDirectory fullNameFor: baseName. newName = oldName ifTrue: [ "Transcript nextPutAll: 'same as old name'; cr." ^ true ]. oldEntry _ FileDirectory directoryEntryFor: oldName. newEntry _ FileDirectory directoryEntryFor: newName. newEntry ifNotNil: [ | msg | msg _ String streamContents: [ :s | s nextPutAll: 'destination file '; nextPutAll: newName; nextPutAll: ' exists already,'; cr; nextPutAll: 'and is '; nextPutAll: (oldEntry modificationTime < newEntry modificationTime ifTrue: [ 'newer' ] ifFalse: [ 'not newer' ]); nextPutAll: ' than source file '; nextPutAll: oldName; nextPut: $.; cr; nextPutAll: 'Overwrite file '; nextPutAll: newName; nextPut: $? ]. response _ self confirm: msg. response ifFalse: [ ^false ]. ]. aTransferMorph shouldCopy ifTrue: [ self primitiveCopyFileNamed: oldName to: newName ] ifFalse: [ directory rename: oldName toBe: newName ]. self updateFileList; fileListIndex: 0. aTransferMorph source model ~= self ifTrue: [ aTransferMorph source model updateFileList; fileListIndex: 0 ]. "Transcript nextPutAll: 'copied'; cr." ^true! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/14/2003 12:58'! dragPassengerFor: item inMorph: dragSource ^self directory fullNameFor: ((self fileNameFromFormattedItem: item contents copy) copyReplaceAll: self folderString with: ''). ! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/14/2003 11:16'! dragTransferTypeForMorph: aMorph ^#file! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'! dropDestinationDirectory: dest event: evt "Answer a FileDirectory representing the drop destination in the volume list morph dest" | index dir delim path | index _ volList indexOf: (dest itemFromPoint: evt position) contents. index = 1 ifTrue: [dir _ FileDirectory on: ''] ifFalse: [delim _ directory pathNameDelimiter. path _ String streamContents: [:str | 2 to: index do: [:d | str nextPutAll: (volList at: d) withBlanksTrimmed. d < index ifTrue: [str nextPut: delim]]. nil]. dir _ directory on: path]. ^ dir! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 21:58'! isDirectoryList: aMorph ^aMorph getListSelector == #volumeList! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/12/2004 16:17'! primitiveCopyFileNamed: srcName to: dstName "Copied from VMMaker code. This really ought to be a facility in file system. The major annoyance here is that file types and permissions are not handled by current Squeak code. NOTE that this will clobber the destination file!!" | buffer src dst | "primitiveExternalCall" "If the plugin doesn't do it, go the slow way and lose the filetype info" "This method may signal FileDoesNotExistException if either the source or dest files cannnot be opened; possibly permissions or bad name problems" [[src _ FileStream readOnlyFileNamed: srcName] on: FileDoesNotExistException do: [^ self error: ('could not open file ', srcName)]. [dst _ FileStream forceNewFileNamed: dstName] on: FileDoesNotExistException do: [^ self error: ('could not open file ', dstName)]. buffer _ String new: 50000. [src atEnd] whileFalse: [dst nextPutAll: (src nextInto: buffer)]] ensure: [src ifNotNil: [src close]. dst ifNotNil: [dst close]]! ! !FileList methodsFor: 'drag''n''drop' stamp: 'nk 6/19/2003 10:08'! wantsDroppedMorph: aTransferMorph event: evt inMorph: dest | retval | retval _ (aTransferMorph isKindOf: TransferMorph) and: [ aTransferMorph dragTransferType == #file ] and: [ self isDirectoryList: dest ]. "retval ifFalse: [ Transcript nextPutAll: 'drop not wanted'; cr ]." ^retval! ! !FileList methodsFor: 'file list' stamp: 'sw 2/17/2002 02:32'! fileListIndex: anInteger "Select the file name having the given index, and display its contents." | item name | self okToChange ifFalse: [^ self]. listIndex := anInteger. listIndex = 0 ifTrue: [fileName := nil] ifFalse: [item := self fileNameFromFormattedItem: (list at: anInteger). (item endsWith: self folderString) ifTrue: ["remove [...] folder string and open the folder" name := item copyFrom: 1 to: item size - self folderString size. listIndex := 0. brevityState := #FileList. self addPath: name. name first = $^ ifTrue: [self directory: (ServerDirectory serverNamed: name allButFirst)] ifFalse: [volListIndex = 1 ifTrue: [name _ name, directory slash]. self directory: (directory directoryNamed: name)]] ifFalse: [fileName := item]]. "open the file selected" brevityState := #needToGetBrief. self changed: #fileListIndex. self changed: #contents. self updateButtonRow! ! !FileList methodsFor: 'file list' stamp: 'sd 2/14/2002 16:58'! fileName ^ fileName! ! !FileList methodsFor: 'file list' stamp: 'nk 4/29/2004 10:34'! readOnlyStream "Answer a read-only stream on the selected file. For the various stream-reading services." ^self directory ifNotNilDo: [ :dir | dir readOnlyFileNamed: self fileName ]! ! !FileList methodsFor: 'file list menu' stamp: 'RAA 2/2/2002 08:18'! dirAndFileName ^{directory. fileName}! ! !FileList methodsFor: 'file list menu' stamp: 'yo 7/5/2004 20:17'! fileContentsMenu: aMenu shifted: shifted "Construct aMenu to have items appropriate for the file browser's code pane, given the shift state provided" | shiftMenu services maybeLine extraLines | shifted ifTrue: [shiftMenu _ ParagraphEditor shiftedYellowButtonMenu. ^ aMenu labels: shiftMenu labelString lines: shiftMenu lineArray selections: shiftMenu selections]. fileName ifNotNil: [services _ OrderedCollection new. (#(briefHex briefFile needToGetBriefHex needToGetBrief) includes: brevityState) ifTrue: [services add: self serviceGet]. (#(fullHex briefHex needToGetFullHex needToGetBriefHex) includes: brevityState) ifFalse: [services add: self serviceGetHex]. (#(needToGetShiftJIS needToGetEUCJP needToGetCNGB needToGetEUCKR needToGetUTF8) includes: brevityState) ifFalse: [services add: self serviceGetEncodedText]. maybeLine _ services size. (FileStream sourceFileSuffixes includes: self suffixOfSelectedFile) ifTrue: [services addAll: (self servicesFromSelectorSpecs: #(fileIntoNewChangeSet: fileIn: browseChangesFile: browseFile:))]. extraLines _ OrderedCollection new. maybeLine > 0 ifTrue: [extraLines add: maybeLine]. services size > maybeLine ifTrue: [extraLines add: services size]. aMenu addServices: services for: self fullName extraLines: extraLines]. aMenu addList: { {'find...(f)' translated. #find}. {'find again (g)' translated. #findAgain}. {'set search string (h)' translated. #setSearchString}. #-. {'do again (j)' translated. #again}. {'undo (z)' translated. #undo}. #-. {'copy (c)' translated. #copySelection}. {'cut (x)' translated. #cut}. {'paste (v)' translated. #paste}. {'paste...' translated. #pasteRecent}. #-. {'do it (d)' translated. #doIt}. {'print it (p)' translated. #printIt}. {'inspect it (i)' translated. #inspectIt}. {'fileIn selection (G)' translated. #fileItIn}. #-. {'accept (s)' translated. #accept}. {'cancel (l)' translated. #cancel}. #-. {'more...' translated. #shiftedYellowButtonActivity}}. ^ aMenu ! ! !FileList methodsFor: 'file list menu' stamp: 'LEG 10/24/2001 15:37'! fileListMenu: aMenu fileName ifNil: [^ self noFileSelectedMenu: aMenu] ifNotNil: [^ self fileSelectedMenu: aMenu]. ! ! !FileList methodsFor: 'file list menu' stamp: 'nk 11/16/2002 13:00'! fileSelectedMenu: aMenu | firstItems secondItems thirdItems n1 n2 n3 services | firstItems _ self itemsForFile: self fullName. secondItems _ self itemsForAnyFile. thirdItems _ self itemsForNoFile. n1 _ firstItems size. n2 _ n1 + secondItems size. n3 _ n2 + thirdItems size. services _ firstItems, secondItems, thirdItems, self serviceAllFileOptions. services do: [ :svc | svc addDependent: self ]. ^ aMenu addServices2: services for: self extraLines: (Array with: n1 with: n2 with: n3) ! ! !FileList methodsFor: 'file list menu' stamp: 'nk 2/15/2004 16:06'! fullFileListMenu: aMenu shifted: aBoolean "Fill the menu with all possible items for the file list pane, regardless of selection." | lastProvider | aMenu title: 'all possible file operations'. Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. lastProvider _ nil. (self itemsForFile: 'a.*') do: [ :svc | (lastProvider notNil and: [svc provider ~~ lastProvider]) ifTrue: [ aMenu addLine ]. svc addServiceFor: self toMenu: aMenu. Smalltalk isMorphic ifTrue: [aMenu submorphs last setBalloonText: svc description]. lastProvider _ svc provider. svc addDependent: self. ]. ^aMenu! ! !FileList methodsFor: 'file list menu' stamp: 'sw 11/8/2003 13:32'! itemsForAnyFile "Answer a list of universal services that could apply to any file" | services | services := OrderedCollection new: 4. services add: self serviceCopyName. services add: self serviceRenameFile. services add: self serviceDeleteFile. services add: self serviceViewContentsInWorkspace. ^ services! ! !FileList methodsFor: 'file list menu' stamp: 'nk 6/12/2004 12:05'! itemsForDirectory: dir | services | services := OrderedCollection new. dir ifNotNil: [ services addAll: (self class itemsForDirectory: dir). services last useLineAfter: true. ]. services add: self serviceAddNewFile. services add: self serviceAddNewDirectory. ^ services! ! !FileList methodsFor: 'file list menu' stamp: 'nk 12/7/2002 12:56'! itemsForFile: fullName "Answer a list of services appropriate for a file of the given full name" | suffix | suffix _ self class suffixOf: fullName. ^ (self class itemsForFile: fullName) , (self myServicesForFile: fullName suffix: suffix)! ! !FileList methodsFor: 'file list menu' stamp: 'nk 6/12/2004 12:06'! itemsForNoFile | services | services := OrderedCollection new. services add: self serviceSortByName. services add: self serviceSortBySize. services add: (self serviceSortByDate useLineAfter: true). services addAll: (self itemsForDirectory: (self isFileSelected ifFalse: [ self directory ] ifTrue: [])). ^ services ! ! !FileList methodsFor: 'file list menu' stamp: 'sd 2/6/2002 21:25'! myServicesForFile: fullName suffix: suffix ^(FileStream isSourceFileSuffix: suffix) ifTrue: [ {self serviceBroadcastUpdate} ] ifFalse: [ #() ]! ! !FileList methodsFor: 'file list menu' stamp: 'SD 11/8/2001 20:34'! noFileSelectedMenu: aMenu ^ aMenu addServices: self itemsForNoFile for: self extraLines: #() ! ! !FileList methodsFor: 'file list menu' stamp: 'sw 2/27/2001 13:52'! offerAllFileOptions "Put up a menu offering all possible file options, whatever the suffix of the current selection may be. Specially useful if you're wanting to keep the menu up" self offerMenuFrom: #fullFileListMenu:shifted: shifted: true! ! !FileList methodsFor: 'file list menu' stamp: 'yo 11/14/2002 15:04'! openMorphFromFile "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world" | aFileStream morphOrList | Smalltalk verifyMorphicAvailability ifFalse: [^ self]. aFileStream _ (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: self fullName) binary contentsOfEntireFile)) binary reset. morphOrList _ aFileStream fileInObjectAndCode. (morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList _ morphOrList contentsMorph]. Smalltalk isMorphic ifTrue: [ActiveWorld addMorphsAndModel: morphOrList] ifFalse: [morphOrList isMorph ifFalse: [^ self errorMustBeMorph]. morphOrList openInWorld]! ! !FileList methodsFor: 'file list menu' stamp: 'nk 12/7/2002 12:57'! suffixOfSelectedFile "Answer the file extension of the receiver's selected file" ^ self class suffixOf: self fullName.! ! !FileList methodsFor: 'file menu action' stamp: 'dgd 12/27/2003 12:18'! addNew: aString byEvaluating: aBlock "A parameterization of earlier versions of #addNewDirectory and #addNewFile. Fixes the bug in each that pushing the cancel button in the FillInTheBlank dialog gave a walkback." | response newName index ending | self okToChange ifFalse: [^ self]. (response := FillInTheBlank request: ('New {1} Name?' translated format: {aString translated}) initialAnswer: ('{1}Name' translated format: {aString translated})) isEmpty ifTrue: [^ self]. newName := response asFileName. Cursor wait showWhile: [ aBlock value: newName]. self updateFileList. index := list indexOf: newName. index = 0 ifTrue: [ending := ') ',newName. index := list findFirst: [:line | line endsWith: ending]]. self fileListIndex: index. ! ! !FileList methodsFor: 'file menu action' stamp: 'ka 8/3/2001 21:12'! compressFile "Compress the currently selected file" | f | f _ StandardFileStream readOnlyFileNamed: (directory fullNameFor: self fullName). f compressFile. self updateFileList! ! !FileList methodsFor: 'file menu action' stamp: 'dgd 9/21/2003 17:37'! deleteFile "Delete the currently selected file" listIndex = 0 ifTrue: [^ self]. (self confirm: ('Really delete {1}?' translated format:{fileName})) ifFalse: [^ self]. directory deleteFileNamed: fileName. self updateFileList. brevityState _ #FileList. self get! ! !FileList methodsFor: 'file menu action' stamp: 'yo 3/31/2003 11:25'! getEncodedText Cursor read showWhile: [ self selectEncoding. self changed: #contents]. ! ! !FileList methodsFor: 'file menu action' stamp: 'dgd 12/27/2003 12:20'! renameFile "Rename the currently selected file" | newName response | listIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (response _ FillInTheBlank request: 'NewFileName?' translated initialAnswer: fileName) isEmpty ifTrue: [^ self]. newName _ response asFileName. newName = fileName ifTrue: [^ self]. directory rename: fileName toBe: newName. self updateFileList. listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. listIndex > 0 ifTrue: [fileName _ newName]. self changed: #fileListIndex. ! ! !FileList methodsFor: 'file menu action' stamp: 'sd 2/1/2002 20:02'! spawn: code "Open a simple Edit window" listIndex = 0 ifTrue: [^ self]. self class openEditorOn: (directory readOnlyFileNamed: fileName) "read only just for initial look" editString: code! ! !FileList methodsFor: 'initialization' stamp: 'sw 11/30/2002 00:05'! buttonSelectorsToSuppress "Answer a list of action selectors whose corresponding services we would prefer *not* to have appear in the filelist's button pane; this can be hand-jimmied to suit personal taste." ^ #(removeLineFeeds: addFileToNewZip: compressFile: putUpdate:)! ! !FileList methodsFor: 'initialization' stamp: 'BG 12/13/2002 15:32'! directory: dir "Set the path of the volume to be displayed." self okToChange ifFalse: [^ self]. self modelSleep. directory _ dir. self modelWakeUp. sortMode == nil ifTrue: [sortMode _ #date]. volList _ ((Array with: '[]'), directory pathParts) "Nesting suggestion from RvL" withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. volListIndex := volList size. self changed: #relabel. self changed: #volumeList. self pattern: pattern! ! !FileList methodsFor: 'initialization' stamp: 'sw 2/26/2002 00:37'! dynamicButtonServices "Answer services for buttons that may come and go in the button pane, depending on selection" ^ fileName isEmptyOrNil ifTrue: [#()] ifFalse: [ | toReject | toReject _ self buttonSelectorsToSuppress. (self itemsForFile: self fullName) reject: [:svc | toReject includes: svc selector]]! ! !FileList methodsFor: 'initialization' stamp: 'nk 1/19/2005 13:25'! modelWakeUp "User has entered or expanded the window -- reopen any remote connection." (directory notNil and:[directory isRemoteDirectory]) ifTrue: [[directory wakeUp] on: TelnetProtocolError do: [ :ex | self inform: ex printString ]] "It would be good to implement a null method wakeUp on the root of directory"! ! !FileList methodsFor: 'initialization' stamp: 'sw 11/30/2002 14:36'! optionalButtonRow "Answer the button row associated with a file list" | aRow | aRow _ AlignmentMorph newRow beSticky. aRow color: Color transparent. aRow clipSubmorphs: true. aRow layoutInset: 5@1; cellInset: 6. self universalButtonServices do: "just the three sort-by items" [:service | aRow addMorphBack: (service buttonToTriggerIn: self). (service selector == #sortBySize) ifTrue: [aRow addTransparentSpacerOfSize: (4@0)]]. aRow setNameTo: 'buttons'. aRow setProperty: #buttonRow toValue: true. "Used for dynamic retrieval later on" ^ aRow! ! !FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 00:07'! optionalButtonSpecs "Answer a list of services underlying the optional buttons in their initial inception." ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! ! !FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 05:39'! optionalButtonView "Answer a view of optional buttons" | aView bHeight windowWidth offset previousView aButtonView wid services sel allServices | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 120. aView window: (0 @ 0 extent: windowWidth @ bHeight). offset _ 0. allServices _ self universalButtonServices. services _ allServices copyFrom: 1 to: (allServices size min: 5). previousView _ nil. services do: [:service | sel _ service selector. aButtonView _ sel asString numArgs = 0 ifTrue: [PluggableButtonView on: service provider getState: (service extraSelector == #none ifFalse: [service extraSelector]) action: sel] ifFalse: [PluggableButtonView on: service provider getState: (service extraSelector == #none ifFalse: [service extraSelector]) action: sel getArguments: #fullName from: self]. service selector = services last selector ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ windowWidth // services size - 2]. aButtonView label: service buttonLabel asParagraph; window: (offset @ 0 extent: wid @ bHeight). offset _ offset + wid. service selector = services first selector ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^ aView! ! !FileList methodsFor: 'initialization' stamp: 'sw 2/17/2002 05:38'! universalButtonServices "Answer a list of services underlying the universal buttons in their initial inception. For the moment, only the sorting buttons are shown." ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize}! ! !FileList methodsFor: 'initialization' stamp: 'gm 2/16/2003 20:38'! updateButtonRow "Dynamically update the contents of the button row, if any." | aWindow aRow | Smalltalk isMorphic ifFalse: [^self]. aWindow := self dependents detect: [:m | (m isSystemWindow) and: [m model == self]] ifNone: [^self]. aRow := aWindow findDeepSubmorphThat: [:m | m hasProperty: #buttonRow] ifAbsent: [^self]. aRow submorphs size - 4 timesRepeat: [aRow submorphs last delete]. self dynamicButtonServices do: [:service | aRow addMorphBack: (service buttonToTriggerIn: self). service addDependent: self]! ! !FileList methodsFor: 'menu messages' stamp: 'sw 11/30/2002 15:38'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If it's one of the three sort-by items, handle it specially. If I can respond myself, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." ^ (#(sortByDate sortBySize sortByName) includes: selector) ifTrue: [self resort: selector] ifFalse: [(#(get getHex copyName openImageInWindow importImage renameFile deleteFile addNewFile) includes: selector) ifTrue: [self perform: selector] ifFalse: [super perform: selector orSendTo: otherTarget]]! ! !FileList methodsFor: 'own services' stamp: 'sw 2/15/2002 19:07'! serviceAddNewDirectory "Answer a service entry characterizing the 'add new directory' command" ^ SimpleServiceEntry provider: self label: 'add new directory' selector: #addNewDirectory description: 'adds a new, empty directory (folder)' ! ! !FileList methodsFor: 'own services' stamp: 'sw 2/11/2002 23:36'! serviceAddNewFile "Answer a service entry characterizing the 'add new file' command" ^ SimpleServiceEntry provider: self label: 'add new file' selector: #addNewFile description: 'create a new,. empty file, and add it to the current directory.'! ! !FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:12'! serviceAllFileOptions ^ {SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions description: 'show all the options available'}! ! !FileList methodsFor: 'own services' stamp: 'sw 2/17/2002 01:36'! serviceBroadcastUpdate "Answer a service for broadcasting a file as an update" ^ SimpleServiceEntry provider: self label: 'broadcast as update' selector: #putUpdate: description: 'broadcast file as update' buttonLabel: 'broadcast'! ! !FileList methodsFor: 'own services' stamp: 'sw 2/17/2002 02:36'! serviceCompressFile "Answer a service for compressing a file" ^ SimpleServiceEntry provider: self label: 'compress' selector: #compressFile description: 'compress file' buttonLabel: 'compress'! ! !FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:16'! serviceCopyName ^ (SimpleServiceEntry provider: self label: 'copy name to clipboard' selector: #copyName description:'copy name to clipboard' )! ! !FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 21:17'! serviceDeleteFile ^ (SimpleServiceEntry provider: self label: 'delete' selector: #deleteFile) description: 'delete the seleted item'! ! !FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'! serviceGet "Answer a service for getting the entire file" ^ (SimpleServiceEntry provider: self label: 'get entire file' selector: #get description: 'if the file has only been partially read in, because it is very large, read the entire file in at this time.')! ! !FileList methodsFor: 'own services' stamp: 'yo 3/31/2003 11:24'! serviceGetEncodedText ^ (SimpleServiceEntry provider: self label: 'view as encoded text' selector: #getEncodedText description: 'view as encoded text') ! ! !FileList methodsFor: 'own services' stamp: 'sd 2/1/2002 20:50'! serviceGetHex ^ (SimpleServiceEntry provider: self label: 'view as hex' selector: #getHex description: 'view as hex') ! ! !FileList methodsFor: 'own services' stamp: 'sd 1/31/2002 22:15'! serviceRenameFile ^ (SimpleServiceEntry provider: self label: 'rename' selector: #renameFile description: 'rename file')! ! !FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'! serviceSortByDate "Answer a service for sorting by date" ^ (SimpleServiceEntry new provider: self label: 'by date' selector: #sortByDate description: 'sort entries by date') extraSelector: #sortingByDate; buttonLabel: 'date'! ! !FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:39'! serviceSortByName "Answer a service for soring by name" ^ (SimpleServiceEntry new provider: self label: 'by name' selector: #sortByName description: 'sort entries by name') extraSelector: #sortingByName; buttonLabel: 'name'! ! !FileList methodsFor: 'own services' stamp: 'sw 2/16/2002 01:40'! serviceSortBySize "Answer a service for sorting by size" ^ (SimpleServiceEntry provider: self label: 'by size' selector: #sortBySize description: 'sort entries by size') extraSelector: #sortingBySize; buttonLabel: 'size'! ! !FileList methodsFor: 'own services' stamp: 'sw 11/8/2003 13:34'! serviceViewContentsInWorkspace "Answer a service for viewing the contents of a file in a workspace" ^ (SimpleServiceEntry provider: self label: 'workspace with contents' selector: #viewContentsInWorkspace) description: 'open a new Workspace whose contents are set to the contents of this file'! ! !FileList methodsFor: 'own services' stamp: 'sw 2/15/2002 20:19'! servicesFromSelectorSpecs: symbolArray "Answer an array of services represented by the incoming symbols, eliminating any that do not have a currently-registered service. Pass the symbol #- along unchanged to serve as a separator between services" "FileList new servicesFromSelectorSpecs: #(fileIn: fileIntoNewChangeSet: browseChangesFile:)" | res services col | col := OrderedCollection new. services := self class allRegisteredServices, (self myServicesForFile: #dummy suffix: '*'). symbolArray do: [:sel | sel == #- ifTrue: [col add: sel] ifFalse: [res := services detect: [:each | each selector = sel] ifNone: [nil]. res notNil ifTrue: [col add: res]]]. ^ col! ! !FileList methodsFor: 'own services' stamp: 'sw 11/8/2003 13:39'! viewContentsInWorkspace "View the contents of my selected file in a new workspace" | aString aFileStream aName | aString _ (aFileStream _ directory readOnlyFileNamed: self fullName) contentsOfEntireFile. aName _ aFileStream localName. aFileStream close. (Workspace new contents: aString) openLabel: 'Workspace from ', aName! ! !FileList methodsFor: 'server list' stamp: 'SD 11/10/2001 17:49'! askServerInfo "Get the user to create a ServerDirectory for a new server. Fill in and say Accept." | template | template _ '"Please fill in the following info, then select all text and choose DoIt." | aa | self flag: #ViolateNonReferenceToOtherClasses. aa _ ServerDirectory new. aa server: ''st.cs.uiuc.edu''. "host" aa user: ''anonymous''. aa password: ''yourEmail@school.edu''. aa directory: ''/Smalltalk/Squeak/Goodies''. aa url: ''''. "<- this is optional. Only used when *writing* update files." ServerDirectory addServer: aa named: ''UIUCArchive''. "<- known by this name in Squeak"'. (StringHolder new contents: template) openLabel: 'FTP Server Form' ! ! !FileList methodsFor: 'server list' stamp: 'di 1/29/2002 21:45'! putUpdate: fullFileName "Put this file out as an Update on the servers." | names choice | self canDiscardEdits ifFalse: [^ self changed: #flash]. names _ ServerDirectory groupNames asSortedArray. choice _ (SelectionMenu labelList: names selections: names) startUp. choice == nil ifTrue: [^ self]. (ServerDirectory serverInGroupNamed: choice) putUpdate: (directory oldFileNamed: fullFileName). self volumeListIndex: volListIndex. ! ! !FileList methodsFor: 'server list' stamp: 'SD 11/10/2001 17:49'! removeServer | choice names | self flag: #ViolateNonReferenceToOtherClasses. names := ServerDirectory serverNames asSortedArray. choice := (SelectionMenu labelList: names selections: names) startUp. choice == nil ifTrue: [^ self]. ServerDirectory removeServerNamed: choice! ! !FileList methodsFor: 'updating' stamp: 'sw 11/30/2002 16:49'! update: aParameter "Receive a change notice from an object of whom the receiver is a dependent" (aParameter == #fileListChanged) ifTrue: [self updateFileList]. super update: aParameter! ! !FileList methodsFor: 'volume list and pattern' stamp: 'tpr 11/28/2003 11:44'! deleteDirectory "Remove the currently selected directory" | localDirName | directory entries size = 0 ifFalse:[^self inform:'Directory must be empty']. localDirName _ directory localName. (self confirm: 'Really delete ' , localDirName , '?') ifFalse: [^ self]. self volumeListIndex: self volumeListIndex-1. directory deleteDirectory: localDirName. self updateFileList.! ! !FileList methodsFor: 'volume list and pattern' stamp: 'SD 11/11/2001 13:59'! directory ^ directory! ! !FileList methodsFor: 'volume list and pattern' stamp: 'sw 2/21/2002 02:01'! volumeListIndex: index "Select the volume name having the given index." | delim path | volListIndex := index. index = 1 ifTrue: [self directory: (FileDirectory on: '')] ifFalse: [delim := directory pathNameDelimiter. path := String streamContents: [:strm | 2 to: index do: [:i | strm nextPutAll: (volList at: i) withBlanksTrimmed. i < index ifTrue: [strm nextPut: delim]]]. self directory: (directory on: path)]. brevityState := #FileList. self addPath: path. self changed: #fileList. self changed: #contents. self updateButtonRow! ! !FileList methodsFor: 'volume menu' stamp: 'nk 6/12/2004 12:07'! volumeMenu: aMenu aMenu addList: { {'recent...' translated. #recentDirs}. #-. {'add server...' translated. #askServerInfo}. {'remove server...' translated. #removeServer}. #-. {'delete directory...' translated. #deleteDirectory}. #-}. aMenu addServices: (self itemsForDirectory: self directory) for: self extraLines: #(). ^aMenu.! ! !FileList methodsFor: 'private' stamp: 'yo 7/5/2004 19:41'! contents "Answer the contents of the file, reading it first if needed." "Possible brevityState values: FileList, fullFile, briefFile, needToGetFull, needToGetBrief, fullHex, briefHex, needToGetFullHex, needToGetBriefHex" (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected" brevityState == #fullFile ifTrue: [^ contents]. brevityState == #fullHex ifTrue: [^ contents]. brevityState == #briefFile ifTrue: [^ contents]. brevityState == #briefHex ifTrue: [^ contents]. brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false]. brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true]. brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false]. brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default" (TextConverter allEncodingNames includes: brevityState) ifTrue: [ ^self readContentsAsEncoding: brevityState]. self halt: 'unknown state ' , brevityState printString! ! !FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:22'! defaultContents contents _ list == nil ifTrue: [String new] ifFalse: [String streamContents: [:s | s nextPutAll: 'NO FILE SELECTED' translated; cr. s nextPutAll: ' -- Folder Summary --' translated; cr. list do: [:item | s nextPutAll: item; cr]]]. brevityState _ #FileList. ^ contents! ! !FileList methodsFor: 'private' stamp: 'yo 7/6/2004 20:52'! defaultEncoderFor: aFileName "This method just illustrates the stupidest possible implementation of encoder selection." | l | l _ aFileName asLowercase. " ((l endsWith: FileStream multiCs) or: [ l endsWith: FileStream multiSt]) ifTrue: [ ^ UTF8TextConverter new. ]. " ((l endsWith: FileStream cs) or: [ l endsWith: FileStream st]) ifTrue: [ ^ MacRomanTextConverter new. ]. ^ Latin1TextConverter new. ! ! !FileList methodsFor: 'private' stamp: 'rhi 9/8/2001 02:17'! fileNameFromFormattedItem: item "Extract fileName and folderString from a formatted fileList item string" | from to | self sortingByName ifTrue: [ from _ item lastIndexOf: $( ifAbsent: [0]. to _ item lastIndexOf: $) ifAbsent: [0]] ifFalse: [ from _ item indexOf: $( ifAbsent: [0]. to _ item indexOf: $) ifAbsent: [0]]. ^ (from * to = 0 ifTrue: [item] ifFalse: [item copyReplaceFrom: from to: to with: '']) withBlanksTrimmed! ! !FileList methodsFor: 'private' stamp: 'sw 1/7/2003 17:08'! fullName "Answer the full name for the currently selected file; answer nil if no file is selected." ^ fileName ifNotNil: [directory ifNil: [FileDirectory default fullNameFor: fileName] ifNotNil: [directory fullNameFor: fileName]] ! ! !FileList methodsFor: 'private' stamp: 'SD 11/14/2001 21:59'! isFileSelected "return if a file is currently selected" ^ fileName isNil not! ! !FileList methodsFor: 'private' stamp: 'nk 2/20/2001 12:36'! listForPatterns: anArray "Make the list be those file names which match the pattern." | sizePad newList | newList _ Set new. anArray do: [ :pat | newList addAll: (self entriesMatching: pat) ]. newList _ (SortedCollection sortBlock: self sortBlock) addAll: newList; yourself. sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. volList size = 1 ifTrue: ["Include known servers along with other desktop volumes" ^ newList asArray , (ServerDirectory serverNames collect: [:n | '^' , n , self folderString])]. ^ newList asArray! ! !FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:24'! put: aText "Private - put the supplied text onto the file" | ff type | brevityState == #fullFile ifTrue: [ff _ directory newFileNamed: self fullName. Cursor write showWhile: [ff nextPutAll: aText asString; close]. fileName = ff localName ifTrue: [contents _ aText asString] ifFalse: [self updateFileList]. "user renamed the file" ^ true "accepted"]. listIndex = 0 ifTrue: [self inform: 'No fileName is selected' translated. ^ false "failed"]. type _ 'These'. brevityState = #briefFile ifTrue: [type _ 'Abbreviated']. brevityState = #briefHex ifTrue: [type _ 'Abbreviated']. brevityState = #fullHex ifTrue: [type _ 'Hexadecimal']. brevityState = #FileList ifTrue: [type _ 'Directory']. self inform: ('{1} contents cannot meaningfully be saved at present.' translated format:{type translated}). ^ false "failed" ! ! !FileList methodsFor: 'private' stamp: 'yo 3/14/2005 13:55'! readContentsAsEncoding: encodingName | f writeStream converter c | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. converter _ TextConverter defaultConverterClassForEncoding: encodingName. converter ifNil: [^ 'This encoding is not supported']. f converter: converter new. f wantsLineEndConversion: true. [f atEnd or: [(c _ f next) isNil]] whileFalse: [writeStream nextPut: c]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'tlk 11/13/2004 19:01'! readContentsBrief: brevityFlag "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." | f fileSize first5000 | brevityFlag ifTrue: [ directory isRemoteDirectory ifTrue: [^ self readServerBrief]]. f := directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read' translated]. f converter: (self defaultEncoderFor: self fullName). (brevityFlag not or: [(fileSize := f size) <= 100000]) ifTrue: [contents := f contentsOfEntireFile. brevityState := #fullFile. "don't change till actually read" ^ contents]. "if brevityFlag is true, don't display long files when first selected" first5000 := f next: 5000. f close. contents := 'File ''{1}'' is {2} bytes long. You may use the ''get'' command to read the entire file. Here are the first 5000 characters... ------------------------------------------ {3} ------------------------------------------ ... end of the first 5000 characters.' translated format: {fileName. fileSize. first5000}. brevityState := #briefFile. "don't change till actually read" ^ contents. ! ! !FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:55'! readContentsCNGB | f writeStream | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. f converter: CNGBTextConverter new. [f atEnd] whileFalse: [writeStream nextPut: f next]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:31'! readContentsEUCJP | f writeStream | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. f converter: EUCJPTextConverter new. [f atEnd] whileFalse: [writeStream nextPut: f next]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'ka 8/24/2000 18:56'! readContentsEUCKR | f writeStream | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. f converter: EUCKRTextConverter new. [f atEnd] whileFalse: [writeStream nextPut: f next]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'yo 3/16/2004 12:55'! readContentsHex: brevity "retrieve the contents from the external file unless it is too long. Don't create a file here. Check if exists." | f size data hexData s | f := directory oldFileOrNoneNamed: self fullName. f == nil ifTrue: [^ 'For some reason, this file cannot be read' translated]. f binary. ((size := f size)) > 5000 & brevity ifTrue: [data := f next: 10000. f close. brevityState := #briefHex] ifFalse: [data := f contentsOfEntireFile. brevityState := #fullHex]. s := WriteStream on: (String new: data size*4). 0 to: data size-1 by: 16 do: [:loc | s nextPutAll: loc hex; space; nextPut: $(; print: loc; nextPut: $); space; tab. loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space]. s cr]. hexData := s contents. ^ contents := ((size > 5000) & brevity ifTrue: ['File ''{1}'' is {2} bytes long. You may use the ''get'' command to read the entire file. Here are the first 5000 characters... ------------------------------------------ {3} ------------------------------------------ ... end of the first 5000 characters.' translated format: {fileName. size. hexData}] ifFalse: [hexData]). ! ! !FileList methodsFor: 'private' stamp: 'ka 8/26/2000 18:48'! readContentsShiftJIS | f writeStream | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. f converter: ShiftJISTextConverter new. [f atEnd] whileFalse: [writeStream nextPut: f next]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'ka 6/23/2002 15:55'! readContentsUTF8 | f writeStream | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. writeStream _ WriteStream on: String new. f converter: UTF8TextConverter new. [f atEnd] whileFalse: [writeStream nextPut: f next]. f close. ^ writeStream contents! ! !FileList methodsFor: 'private' stamp: 'dgd 12/27/2003 12:09'! readServerBrief | lString sizeStr fsize ff first5000 parts | "If file on server is known to be long, just read the beginning. Cheat badly by reading the fileList string." listIndex = 0 ifTrue: [^ self]. "Get size from file list entry" lString := list at: listIndex. parts := lString findTokens: '()'. sortMode = #name ifTrue: [sizeStr := (parts second findTokens: ' ') third]. sortMode = #date ifTrue: [sizeStr := (parts first findTokens: ' ') third]. sortMode = #size ifTrue: [sizeStr := (parts first findTokens: ' ') first]. fsize := (sizeStr copyWithout: $,) asNumber. fsize <= 50000 ifTrue: [ff := directory oldFileOrNoneNamed: self fullName. ff ifNil: [^ 'For some reason, this file cannot be read' translated]. contents := ff contentsOfEntireFile. brevityState := #fullFile. "don't change till actually read" ^ contents]. "if brevityFlag is true, don't display long files when first selected" first5000 := directory getOnly: 3500 from: fileName. contents := 'File ''{1}'' is {2} bytes long. You may use the ''get'' command to read the entire file. Here are the first 3500 characters... ------------------------------------------ {3} ------------------------------------------ ... end of the first 3500 characters.' translated format: {fileName. sizeStr. first5000}. brevityState := #briefFile. "don't change till actually read" ^ contents. ! ! !FileList methodsFor: 'private' stamp: 'SD 11/8/2001 21:11'! registeredFileReaderClasses "return the list of classes that provide file reader services" ^ self class registeredFileReaderClasses! ! !FileList methodsFor: 'private' stamp: 'sw 11/30/2002 16:34'! resort: newMode "Re-sort the list of files." | name | listIndex > 0 ifTrue: [name _ self fileNameFromFormattedItem: (list at: listIndex)]. sortMode _ newMode. self pattern: pattern. name ifNotNil: [ fileName _ name. listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = name. ]. self changed: #fileListIndex]. listIndex = 0 ifTrue: [self changed: #contents]. self updateButtonRow ! ! !FileList methodsFor: 'private' stamp: 'mu 8/22/2003 01:46'! selectEncoding | aMenu encodingItems | aMenu _ CustomMenu new. encodingItems _ OrderedCollection new. TextConverter allSubclasses do: [:each | | names | names _ each encodingNames. names notEmpty ifTrue: [ | label | label _ '' writeStream. names do: [:eachName | label nextPutAll: eachName ] separatedBy: [ label nextPutAll: ', ']. encodingItems add: {label contents. names first asSymbol}. ]. ]. aMenu addList: encodingItems. brevityState _ aMenu startUp. brevityState ifNil: [brevityState _ #needToGetBrief]. ! ! !FileList methodsFor: 'private' stamp: 'nk 12/10/2002 07:57'! updateFileList "Update my files list with file names in the current directory that match the pattern. The pattern string may have embedded newlines or semicolons; these separate different patterns." | patterns | patterns _ OrderedCollection new. Cursor wait showWhile: [ (pattern findTokens: (String with: Character cr with: Character lf with: $;)) do: [ :each | (each includes: $*) | (each includes: $#) ifTrue: [ patterns add: each] ifFalse: [each isEmpty ifTrue: [ patterns add: '*'] ifFalse: [ patterns add: '*' , each , '*']]]. list _ self listForPatterns: patterns. listIndex _ 0. volListIndex _ volList size. fileName _ nil. contents _ ''. self changed: #volumeListIndex. self changed: #fileList. self updateButtonRow]! ! !FileList commentStamp: 'nk 11/26/2002 11:52' prior: 0! I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file. The FileList now provides a registration mechanism to which any tools the filelist uses ***MUST*** register. This way it is possible to dynamically load or unload a new tool and have the FileList automatically updated. This change supports a decomposition of Squeak and removes a problem with dead reference to classes after a major shrink. Tools should implement the following methods (look for implementors in the image): #fileReaderServicesForFile:suffix: (appropriate services for given file, takes a file name and a lowercased suffix) #services (all provided services, to be displayed in full list) These methods both return a collection of SimpleServiceEntry instances. These contain a class, a menu label and a method selector having one argument. They may also provide separate button labels and description. The argument to the specified method will be a string representing the full name of a file when one is selected or the file list itself when there is no selected file. Tools must register with the FileList calling the class method #registerFileReader: when they load. They also must call #unregisterFileReader: when they unload. There is a testSuite called FileListTest that presents some examples. Stef (I do not like really this distinction passing always a file list could be better) Old Comments: FileLists can now see FTP servers anywhere on the net. In the volume list menu: fill in server info... Gives you a form to register a new ftp server you want to use. open server... Choose a server to connect to. local disk Go back to looking at your local volume. Still undone (you can contribute code): [ ] Using a Proxy server to get out through a firewall. What is the convention for proxy servers with FTP? [ ] Fill in the date and size info in the list of remote files. Allow sorting by it. New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:). [ ] Currently the FileList has no way to delete a directory. Since you can't select a directory without going into it, it would have to be deleting the current directory. Which would usually be empty.! !FileList class methodsFor: 'instance creation' stamp: 'nk 6/15/2003 13:04'! addButtonsAndFileListPanesTo: window at: upperFraction plus: offset forFileList: aFileList | fileListMorph row buttonHeight fileListTop divider dividerDelta buttons | fileListMorph _ PluggableListMorph on: aFileList list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. fileListMorph enableDrag: true; enableDrop: false. aFileList wantsOptionalButtons ifTrue: [buttons _ aFileList optionalButtonRow. divider _ BorderedSubpaneDividerMorph forBottomEdge. dividerDelta _ 0. Preferences alternativeWindowLook ifTrue: [buttons color: Color transparent. buttons submorphsDo: [:m | m borderWidth: 2; borderColor: #raised]. divider extent: 4 @ 4; color: Color transparent; borderColor: #raised; borderWidth: 2. fileListMorph borderColor: Color transparent. dividerDelta _ 3]. row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 2; layoutPolicy: ProportionalLayout new. buttonHeight _ self defaultButtonPaneHeight. row addMorph: buttons fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ 0 corner: 0 @ buttonHeight)). row addMorph: divider fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ buttonHeight corner: 0 @ buttonHeight + dividerDelta)). row addMorph: fileListMorph fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ buttonHeight + dividerDelta corner: 0 @ 0)). window addMorph: row fullFrame: (LayoutFrame fractions: upperFraction offsets: (0 @ offset corner: 0 @ 0)). Preferences alternativeWindowLook ifTrue: [row borderWidth: 2] ifFalse: [row borderWidth: 0]] ifFalse: [fileListTop _ 0. window addMorph: fileListMorph frame: (0.3 @ fileListTop corner: 1 @ 0.3)].! ! !FileList class methodsFor: 'instance creation' stamp: 'nk 4/28/2004 10:18'! addVolumesAndPatternPanesTo: window at: upperFraction plus: offset forFileList: aFileList | row patternHeight volumeListMorph patternMorph divider dividerDelta | row _ AlignmentMorph newColumn hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 0; borderWidth: 0; layoutPolicy: ProportionalLayout new. patternHeight _ 25. volumeListMorph _ (PluggableListMorph on: aFileList list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:) autoDeselect: false. volumeListMorph enableDrag: false; enableDrop: true. patternMorph _ PluggableTextMorph on: aFileList text: #pattern accept: #pattern:. patternMorph acceptOnCR: true. patternMorph hideScrollBarsIndefinitely. divider _ BorderedSubpaneDividerMorph horizontal. dividerDelta _ 0. Preferences alternativeWindowLook ifTrue: [divider extent: 4 @ 4; color: Color transparent; borderColor: #raised; borderWidth: 2. volumeListMorph borderColor: Color transparent. patternMorph borderColor: Color transparent. dividerDelta _ 3]. row addMorph: (volumeListMorph autoDeselect: false) fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ 0 corner: 0 @ patternHeight negated - dividerDelta)). row addMorph: divider fullFrame: (LayoutFrame fractions: (0 @ 1 corner: 1 @ 1) offsets: (0 @ patternHeight negated - dividerDelta corner: 0 @ patternHeight negated)). row addMorph: patternMorph fullFrame: (LayoutFrame fractions: (0 @ 1 corner: 1 @ 1) offsets: (0 @ patternHeight negated corner: 0 @ 0)). window addMorph: row fullFrame: (LayoutFrame fractions: upperFraction offsets: (0 @ offset corner: 0 @ 0)). Preferences alternativeWindowLook ifTrue: [row borderWidth: 2] ifFalse: [row borderWidth: 0]! ! !FileList class methodsFor: 'instance creation' stamp: 'sw 9/28/2001 09:21'! defaultButtonPaneHeight "Answer the user's preferred default height for new button panes." ^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! ! !FileList class methodsFor: 'instance creation' stamp: 'sbw 8/29/2001 19:37'! openAsMorph "Open a morphic view of a FileList on the default directory." | dir aFileList window upperFraction offset | dir _ FileDirectory default. aFileList _ self new directory: dir. window _ (SystemWindow labelled: dir pathName) model: aFileList. upperFraction _ 0.3. offset _ 0. self addVolumesAndPatternPanesTo: window at: (0 @ 0 corner: 0.3 @ upperFraction) plus: offset forFileList: aFileList. self addButtonsAndFileListPanesTo: window at: (0.3 @ 0 corner: 1.0 @ upperFraction) plus: offset forFileList: aFileList. window addMorph: (PluggableTextMorph on: aFileList text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:) frame: (0 @ 0.3 corner: 1 @ 1). ^ window! ! !FileList class methodsFor: 'instance creation' stamp: 'SD 11/8/2001 21:21'! openEditorOn: aFileStream editString: editString "Open an editor on the given FileStream." | fileModel topView fileContentsView | Smalltalk isMorphic ifTrue: [^ (self openMorphOn: aFileStream editString: editString) openInWorld]. fileModel _ FileList new setFileStream: aFileStream. "closes the stream" topView _ StandardSystemView new. topView model: fileModel; label: aFileStream fullName; minimumSize: 180@120. topView borderWidth: 1. fileContentsView _ PluggableTextView on: fileModel text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:. fileContentsView window: (0@0 extent: 180@120). topView addSubView: fileContentsView. editString ifNotNil: [fileContentsView editString: editString. fileContentsView hasUnacceptedEdits: true]. topView controller open. ! ! !FileList class methodsFor: 'instance creation' stamp: 'SD 11/8/2001 21:20'! openFileDirectly | aResult | (aResult _ StandardFileMenu oldFile) ifNotNil: [self openEditorOn: (aResult directory readOnlyFileNamed: aResult name) editString: nil]! ! !FileList class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:38'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" ^ self openAsMorph applyModelExtent! ! !FileList class methodsFor: 'class initialization' stamp: 'dvf 8/23/2003 12:17'! initialize "FileList initialize" RecentDirs := OrderedCollection new. (self systemNavigation allClassesImplementing: #fileReaderServicesForFile:suffix:) do: [:providerMetaclass | self registerFileReader: providerMetaclass soleInstance]! ! !FileList class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:47'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(FileList prototypicalToolWindow 'File List' 'A File List is a tool for browsing folders and files on disks and on ftp types.') forFlapNamed: 'Tools']! ! !FileList class methodsFor: 'class initialization' stamp: 'asm 4/08/2003 12:15'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !FileList class methodsFor: 'file reader registration' stamp: 'sd 2/1/2002 21:30'! allRegisteredServices "self allRegisteredServices" | col | col := OrderedCollection new. self registeredFileReaderClasses do: [:each | col addAll: (each services)]. ^ col! ! !FileList class methodsFor: 'file reader registration' stamp: 'sd 1/31/2002 21:42'! detectService: aBlock ifNone: anotherBlock "self detectService: [:each | each selector = #fileIn:] ifNone: [nil]" ^ self allRegisteredServices detect: aBlock ifNone: anotherBlock! ! !FileList class methodsFor: 'file reader registration' stamp: 'SD 11/11/2001 13:53'! isReaderNamedRegistered: aSymbol "return if a given reader class has been registered. Note that this is on purpose that the argument is a symbol and not a class" ^ (self registeredFileReaderClasses collect: [:each | each name]) includes: aSymbol ! ! !FileList class methodsFor: 'file reader registration' stamp: 'nk 6/12/2004 11:42'! itemsForDirectory: aFileDirectory "Answer a list of services appropriate when no file is selected." | services | services _ OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [services addAll: (reader fileReaderServicesForDirectory: aFileDirectory) ]]. ^ services! ! !FileList class methodsFor: 'file reader registration' stamp: 'nk 12/7/2002 12:53'! itemsForFile: fullName "Answer a list of services appropriate for a file of the given full name" | services suffix | suffix _ self suffixOf: fullName. services _ OrderedCollection new. self registeredFileReaderClasses do: [:reader | reader ifNotNil: [services addAll: (reader fileReaderServicesForFile: fullName suffix: suffix)]]. ^ services! ! !FileList class methodsFor: 'file reader registration' stamp: 'SD 11/8/2001 21:17'! registerFileReader: aProviderClass "register the given class as providing services for reading files" | registeredReaders | registeredReaders := self registeredFileReaderClasses. (registeredReaders includes: aProviderClass) ifFalse: [ registeredReaders addLast: aProviderClass ]! ! !FileList class methodsFor: 'file reader registration' stamp: 'SD 11/8/2001 21:11'! registeredFileReaderClasses FileReaderRegistry ifNil: [FileReaderRegistry _ OrderedCollection new]. ^ FileReaderRegistry ! ! !FileList class methodsFor: 'file reader registration' stamp: 'nk 12/7/2002 12:52'! suffixOf: aName "Answer the file extension of the given file" ^ aName ifNil: [''] ifNotNil: [(FileDirectory extensionFor: aName) asLowercase]! ! !FileList class methodsFor: 'file reader registration' stamp: 'SD 11/8/2001 21:18'! unregisterFileReader: aProviderClass "unregister the given class as providing services for reading files" self registeredFileReaderClasses remove: aProviderClass ifAbsent: [nil]! ! !FileList class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:04'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'File List' brightColor: #lightMagenta pastelColor: #paleMagenta helpMessage: 'A tool for looking at files'! ! !FileList2 methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 13:07'! dropDestinationDirectory: dest event: evt "Answer a FileDirectory representing the drop destination in the directory hierarchy morph dest" ^ (dest itemFromPoint: evt position) withoutListWrapper! ! !FileList2 methodsFor: 'drag''n''drop' stamp: 'nk 6/15/2003 22:00'! isDirectoryList: aMorph ^aMorph isKindOf: SimpleHierarchicalListMorph! ! !FileList2 methodsFor: 'initialization' stamp: 'tpr 12/1/2003 17:14'! directory: dir "Set the path of the volume to be displayed." self okToChange ifFalse: [^ self]. self modelSleep. directory _ dir. self modelWakeUp. sortMode == nil ifTrue: [sortMode _ #date]. volList _ Array with: '[]'. directory ifNotNil: [ volList _ volList, directory pathParts. "Nesting suggestion from RvL" ]. volList _ volList withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. self changed: #relabel. self changed: #volumeList. self pattern: pattern. directoryChangeBlock ifNotNil: [directoryChangeBlock value: directory].! ! !FileList2 methodsFor: 'initialization' stamp: 'ar 2/12/2001 16:12'! initialDirectoryList | dir nameToShow dirList | dirList _ (FileDirectory on: '') directoryNames collect: [ :each | FileDirectoryWrapper with: (FileDirectory on: each) name: each model: self]. dirList isEmpty ifTrue:[ dirList _ Array with: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. dirList _ dirList,( ServerDirectory serverNames collect: [ :n | dir _ ServerDirectory serverNamed: n. nameToShow _ n. (dir directoryWrapperClass with: dir name: nameToShow model: self) balloonText: dir realUrl ] ). ^dirList! ! !FileList2 methodsFor: 'initialization' stamp: 'mir 2/6/2004 17:25'! limitedSuperSwikiDirectoryList | dir nameToShow dirList localDirName localDir | dirList _ OrderedCollection new. ServerDirectory serverNames do: [ :n | dir _ ServerDirectory serverNamed: n. dir isProjectSwiki ifTrue: [ nameToShow _ n. dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) balloonText: dir realUrl) ]. ]. ServerDirectory localProjectDirectories do: [ :each | dirList add: (FileDirectoryWrapper with: each name: each localName model: self) ]. "Make sure the following are always shown, but not twice" localDirName := SecurityManager default untrustedUserDirectory. localDir := FileDirectory on: localDirName. ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName) ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)]. FileDirectory default pathName = localDirName ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. (dirList anySatisfy: [:each | each withoutListWrapper acceptsUploads]) ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. ^dirList! ! !FileList2 methodsFor: 'initialization' stamp: 'mir 2/6/2004 17:25'! limitedSuperSwikiPublishDirectoryList | dirList localDirName localDir | dirList _ self publishingServers. ServerDirectory localProjectDirectories do: [ :each | dirList add: (FileDirectoryWrapper with: each name: each localName model: self)]. "Make sure the following are always shown, but not twice" localDirName := SecurityManager default untrustedUserDirectory. localDir := FileDirectory on: localDirName. ((ServerDirectory localProjectDirectories collect: [:each | each pathName]) includes: localDirName) ifFalse: [dirList add: (FileDirectoryWrapper with: localDir name: localDir localName model: self)]. FileDirectory default pathName = localDirName ifFalse: [dirList add: (FileDirectoryWrapper with: FileDirectory default name: FileDirectory default localName model: self)]. ^dirList! ! !FileList2 methodsFor: 'initialization' stamp: 'mir 11/15/2001 18:16'! publishingServers | dir nameToShow dirList | dirList _ OrderedCollection new. ServerDirectory serverNames do: [ :n | dir _ ServerDirectory serverNamed: n. (dir isProjectSwiki and: [dir acceptsUploads]) ifTrue: [ nameToShow _ n. dirList add: ((dir directoryWrapperClass with: dir name: nameToShow model: self) balloonText: dir realUrl)]]. ^dirList! ! !FileList2 methodsFor: 'initialization' stamp: 'sw 2/22/2002 02:34'! universalButtonServices "Answer the services to be reflected in the receiver's buttons" ^ self optionalButtonSpecs! ! !FileList2 methodsFor: 'initialization' stamp: 'nk 6/14/2004 09:39'! updateDirectory "directory has been changed externally, by calling directory:. Now change the view to reflect the change." self changed: #currentDirectorySelected. self postOpen.! ! !FileList2 methodsFor: 'own services' stamp: 'nk 6/14/2004 09:43'! addNewDirectory super addNewDirectory. self updateDirectory.! ! !FileList2 methodsFor: 'own services' stamp: 'nk 6/14/2004 09:42'! deleteDirectory super deleteDirectory. self updateDirectory.! ! !FileList2 methodsFor: 'own services' stamp: 'sd 5/11/2003 22:15'! importImage "Import the given image file and store the resulting Form in the default Imports" | fname image | fname _ fileName sansPeriodSuffix. image _ Form fromFileNamed: self fullName. Imports default importImage: image named: fname. ! ! !FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:35'! okayAndCancelServices "Answer ok and cancel services" ^ {self serviceOkay. self serviceCancel}! ! !FileList2 methodsFor: 'own services' stamp: 'nk 1/6/2004 12:36'! openImageInWindow "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP. Fail if file format is not recognized." | image myStream | myStream _ (directory readOnlyFileNamed: fileName) binary. image _ Form fromBinaryStream: myStream. myStream close. Smalltalk isMorphic ifTrue: [(World drawingClass withForm: image) openInWorld] ifFalse: [FormView open: image named: fileName]! ! !FileList2 methodsFor: 'own services' stamp: 'hg 8/3/2000 16:55'! openProjectFromFile "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world." Project canWeLoadAProjectNow ifFalse: [^ self]. ProjectViewMorph openFromDirectory: directory andFileName: fileName ! ! !FileList2 methodsFor: 'own services' stamp: 'yo 7/31/2004 18:08'! removeLinefeeds "Remove any line feeds by converting to CRs instead. This is a temporary implementation for 3.6 only... should be removed during 3.7alpha." | fileContents | fileContents _ ((FileStream readOnlyFileNamed: self fullName) wantsLineEndConversion: true) contentsOfEntireFile. (FileStream newFileNamed: self fullName) nextPutAll: fileContents; close.! ! !FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'! serviceCancel "Answer a service for hitting the cancel button" ^ (SimpleServiceEntry new provider: self label: 'cancel' selector: #cancelHit description: 'hit here to cancel ') buttonLabel: 'cancel'! ! !FileList2 methodsFor: 'own services' stamp: 'nk 6/8/2004 17:09'! serviceOkay "Answer a service for hitting the okay button" ^ (SimpleServiceEntry new provider: self label: 'okay' selector: #okHit description: 'hit here to accept the current selection') buttonLabel: 'ok'! ! !FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:07'! serviceOpenProjectFromFile "Answer a service for opening a .pr project file" ^ SimpleServiceEntry provider: self label: 'load as project' selector: #openProjectFromFile description: 'open project from file' buttonLabel: 'load'! ! !FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'! servicesForFolderSelector "Answer the ok and cancel servies for the folder selector" ^ self okayAndCancelServices! ! !FileList2 methodsFor: 'own services' stamp: 'sw 2/22/2002 02:36'! servicesForProjectLoader "Answer the services to show in the button pane for the project loader" ^ {self serviceSortByName. self serviceSortByDate. self serviceSortBySize. self serviceOpenProjectFromFile}! ! !FileList2 methodsFor: 'user interface' stamp: 'yo 3/15/2005 12:38'! blueButtonForService: aService textColor: textColor inWindow: window | block | block _ [ aService performServiceFor: self ] copy fixTemps. ^(window fancyText: aService buttonLabel capitalized translated ofSize: 15 color: textColor) setProperty: #buttonText toValue: aService buttonLabel capitalized; hResizing: #rigid; extent: 100@20; layoutInset: 4; borderWidth: 0; useRoundedCorners; setBalloonText: aService label translated; on: #mouseUp send: #value to: block ! ! !FileList2 methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'! morphicDirectoryTreePane ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList ! ! !FileList2 methodsFor: 'user interface' stamp: 'rww 12/13/2003 13:07'! morphicDirectoryTreePaneFiltered: aSymbol ^(SimpleHierarchicalListMorph on: self list: aSymbol selected: #currentDirectorySelected changeSelected: #setSelectedDirectoryTo: menu: #volumeMenu: keystroke: nil) autoDeselect: false; enableDrag: false; enableDrop: true; yourself ! ! !FileList2 methodsFor: 'user interface' stamp: 'nk 6/15/2003 13:05'! morphicFileListPane ^(PluggableListMorph on: self list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:) enableDrag: true; enableDrop: false; yourself ! ! !FileList2 methodsFor: 'volume list and pattern' stamp: 'nk 6/14/2004 09:45'! changeDirectoryTo: aFileDirectory "Change directory as requested." self directory: aFileDirectory. self updateDirectory! ! !FileList2 methodsFor: 'volume list and pattern' stamp: 'mir 8/24/2001 12:03'! listForPattern: pat "Make the list be those file names which match the pattern." | sizePad newList entries | directory ifNil: [^#()]. entries _ (Preferences eToyLoginEnabled and: [Utilities authorNamePerSe notNil]) ifTrue: [directory matchingEntries: {'submittedBy: ' , Utilities authorName.} ] ifFalse: [directory entries]. (fileSelectionBlock isKindOf: MessageSend) ifTrue: [ fileSelectionBlock arguments: {entries}. newList _ fileSelectionBlock value. fileSelectionBlock arguments: #(). ] ifFalse: [ newList _ entries select: [:entry | fileSelectionBlock value: entry value: pat]. ]. newList _ newList asSortedCollection: self sortBlock. sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. ^ newList asArray! ! !FileList2 methodsFor: 'volume list and pattern' stamp: 'nk 2/20/2001 12:09'! listForPatterns: anArray "Make the list be those file names which match the patterns." | sizePad newList | directory ifNil: [^#()]. (fileSelectionBlock isKindOf: MessageSend) ifTrue: [ fileSelectionBlock arguments: {directory entries}. newList _ fileSelectionBlock value. fileSelectionBlock arguments: #(). ] ifFalse: [ newList _ Set new. anArray do: [ :pat | newList addAll: (directory entries select: [:entry | fileSelectionBlock value: entry value: pat]) ]. ]. newList _ newList asSortedCollection: self sortBlock. sizePad _ (newList inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. ^ newList asArray! ! !FileList2 methodsFor: 'private' stamp: 'RAA 4/6/2001 12:45'! cancelHit modalView delete. directory _ fileName _ currentDirectorySelected _ nil.! ! !FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:50'! currentDirectorySelected ^ currentDirectorySelected ! ! !FileList2 methodsFor: 'private' stamp: 'ar 2/12/2001 16:20'! directoryNamesFor: item "item may be file directory or server directory" | entries | entries _ item directoryNames. dirSelectionBlock ifNotNil:[entries _ entries select: dirSelectionBlock]. ^entries! ! !FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:51'! getSelectedDirectory ok == true ifFalse: [^ nil]. ^ currentDirectorySelected ! ! !FileList2 methodsFor: 'private' stamp: 'sw 9/12/2002 00:43'! getSelectedFile "Answer a filestream on the selected file. If it cannot be opened for read/write, try read-only before giving up; answer nil if unsuccessful" ok == true ifFalse: [^ nil]. directory ifNil: [^ nil]. fileName ifNil: [^ nil]. ^ (directory oldFileNamed: fileName) ifNil: [directory readOnlyFileNamed: fileName]! ! !FileList2 methodsFor: 'private' stamp: 'md 10/22/2003 15:27'! okHit ok _ true. currentDirectorySelected ifNil: [Beeper beep] ifNotNil: [modalView delete]! ! !FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 06:44'! okHitForProjectLoader | areaOfProgress | ok _ true. areaOfProgress _ modalView firstSubmorph. [ areaOfProgress setProperty: #deleteOnProgressCompletion toValue: modalView. self openProjectFromFile. modalView delete. "probably won't get here" ] on: ProgressTargetRequestNotification do: [ :ex | ex resume: areaOfProgress]. ! ! !FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 07:12'! saveLocalOnlyHit ok _ true. modalView delete. directory _ fileName _ nil. currentDirectorySelected _ #localOnly.! ! !FileList2 methodsFor: 'private' stamp: 'LC 1/6/2002 09:03'! setSelectedDirectoryTo: aFileDirectoryWrapper currentDirectorySelected _ aFileDirectoryWrapper. self directory: aFileDirectoryWrapper withoutListWrapper. brevityState := #FileList. "self addPath: path." self changed: #fileList. self changed: #contents. self changed: #currentDirectorySelected.! ! !FileList2 commentStamp: 'BJP 11/19/2003 21:13' prior: 0! Some variations on FileList that - use a hierarchical pane to show folder structure - use different pane combinations, button layouts and prefiltering for specific uses FileList2 morphicView openInWorld "an alternative to the standard FileList" FileList2 morphicViewNoFile openInWorld "useful for selecting, but not viewing" FileList2 morphicViewProjectLoader openInWorld "useful for finding and loading projects" FileList2 modalFolderSelector "allows the user to select a folder" ! ]style[(169 38 41 43 39 48 41 36 36 4)f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1,f1cblue;,f1! !FileList2 class methodsFor: 'class initialization' stamp: 'nk 6/14/2004 08:47'! initialize Preferences addPreference: #useFileList2 categories: #(general) default: true balloonHelp: 'if true, then when you open a file list from the World menu, it''ll be an enhanced one' projectLocal: false changeInformee: self changeSelector: #useFileList2preferenceChanged! ! !FileList2 class methodsFor: 'as yet unclassified' stamp: 'RAA 2/19/2001 06:57'! projectOnlySelectionMethod: incomingEntries | versionsAccepted basicInfoTuple basicName basicVersion | "this shows only the latest version of each project" versionsAccepted _ Dictionary new. incomingEntries do: [ :entry | entry isDirectory ifFalse: [ (#('*.pr' '*.pr.gz' '*.project') anySatisfy: [ :each | each match: entry name]) ifTrue: [ basicInfoTuple _ Project parseProjectFileName: entry name. basicName _ basicInfoTuple first. basicVersion _ basicInfoTuple second. ((versionsAccepted includesKey: basicName) and: [(versionsAccepted at: basicName) first > basicVersion]) ifFalse: [ versionsAccepted at: basicName put: {basicVersion. entry} ]. ] ] ]. ^versionsAccepted asArray collect: [ :each | each second]! ! !FileList2 class methodsFor: 'blue ui' stamp: 'dgd 8/27/2004 18:32'! blueButtonText: aString textColor: textColor inWindow: window ^(window fancyText: aString translated ofSize: 15 color: textColor) setProperty: #buttonText toValue: aString; hResizing: #rigid; extent: 100@20; layoutInset: 4; borderWidth: 0; useRoundedCorners ! ! !FileList2 class methodsFor: 'blue ui' stamp: 'dgd 8/27/2004 18:32'! blueButtonText: aString textColor: textColor inWindow: window balloonText: balloonText selector: sel recipient: recip ^(window fancyText: aString translated ofSize: 15 color: textColor) setProperty: #buttonText toValue: aString; hResizing: #rigid; extent: 100@20; layoutInset: 4; borderWidth: 0; useRoundedCorners; setBalloonText: balloonText; on: #mouseUp send: sel to: recip ! ! !FileList2 class methodsFor: 'blue ui' stamp: 'nk 7/16/2003 17:13'! enableTypeButtons: typeButtons info: fileTypeInfo forDir: aDirectory | foundSuffixes fileSuffixes firstEnabled enableIt | firstEnabled _ nil. foundSuffixes _ (aDirectory ifNil: [ #()] ifNotNil: [ aDirectory fileNames]) collect: [ :each | (each findTokens: '.') last asLowercase]. foundSuffixes _ foundSuffixes asSet. fileTypeInfo with: typeButtons do: [ :info :button | fileSuffixes _ info second. enableIt _ fileSuffixes anySatisfy: [ :patt | foundSuffixes includes: patt]. button setProperty: #enabled toValue: enableIt. enableIt ifTrue: [firstEnabled ifNil: [firstEnabled _ button]]. ]. firstEnabled ifNotNil: [^firstEnabled mouseUp: nil]. typeButtons do: [ :each | each color: Color gray]. ! ! !FileList2 class methodsFor: 'blue ui' stamp: 'yo 3/15/2005 12:24'! endingSpecs "Answer a collection of specs to build the selective 'find anything' tool called by the Navigator. This version uses the services registry to do so." "FileList2 morphicViewGeneralLoaderInWorld: World" | categories services specs rejects | rejects _ #(addFileToNewZip: compressFile: openInZipViewer: extractAllFrom: openOn:). categories _ #( ('Art' ('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png' 'pcx' 'xbm' 'xpm' 'ppm' 'pbm')) ('Morphs' ('morph' 'morphs' 'sp')) ('Projects' ('extseg' 'project' 'pr')) ('Books' ('bo')) ('Music' ('mid')) ('Movies' ('movie' 'mpg' 'mpeg' 'qt' 'mov')) "('Code' ('st' 'cs'))" ('Flash' ('swf')) ('TrueType' ('ttf')) ('3ds' ('3ds')) ('Tape' ('tape')) ('Wonderland' ('wrl')) ('HTML' ('htm' 'html')) ). categories first at: 2 put: ImageReadWriter allTypicalFileExtensions. specs _ OrderedCollection new. categories do: [ :cat | | catSpecs catServices okExtensions | services _ Dictionary new. catSpecs _ Array new: 3. catServices _ OrderedCollection new. okExtensions _ Set new. cat second do: [ :ext | (FileList itemsForFile: 'fred.',ext) do: [ :i | (rejects includes: i selector) ifFalse: [ okExtensions add: ext. services at: i label put: i ]]]. services do: [ :svc | catServices add: svc ]. services isEmpty ifFalse: [ catSpecs at: 1 put: cat first translated; at: 2 put: okExtensions; at: 3 put: catServices. specs add: catSpecs ] ]. ^specs ! ! !FileList2 class methodsFor: 'blue ui' stamp: 'dgd 8/27/2004 18:34'! morphicViewGeneralLoaderInWorld: aWorld " FileList2 morphicViewGeneralLoaderInWorld: self currentWorld " | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b fileTypeInfo fileTypeButtons fileTypeRow actionRow | fileTypeInfo _ self endingSpecs. window _ AlignmentMorphBob1 newColumn. window hResizing: #shrinkWrap; vResizing: #shrinkWrap. textColor1 _ Color r: 0.742 g: 0.839 b: 1.0. aFileList _ self new directory: FileDirectory default. aFileList fileSelectionBlock: self projectOnlySelectionBlock; modalView: window. window setProperty: #FileList toValue: aFileList; wrapCentering: #center; cellPositioning: #topCenter; borderWidth: 4; borderColor: (Color r: 0.355 g: 0.516 b: 1.0); useRoundedCorners. fileTypeButtons _ fileTypeInfo collect: [ :each | (self blueButtonText: each first textColor: Color gray inWindow: window) setProperty: #enabled toValue: true; hResizing: #shrinkWrap ]. buttons _ #('OK' 'Cancel') collect: [ :each | self blueButtonText: each textColor: textColor1 inWindow: window ]. treePane _ aFileList morphicDirectoryTreePane extent: 250@300; retractable: false; borderWidth: 0. fileListPane _ aFileList morphicFileListPane extent: 350@300; retractable: false; borderWidth: 0. window addARow: {window fancyText: 'Find...' translated ofSize: 21 color: textColor1}. fileTypeRow _ window addARowCentered: fileTypeButtons. actionRow _ window addARowCentered: { buttons first. (Morph new extent: 30@5) color: Color transparent. buttons second }. window addARow: { (window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) useRoundedCorners; layoutInset: 6}) layoutInset: 10. (window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) useRoundedCorners; layoutInset: 6}) layoutInset: 10. }. window fullBounds. window fillWithRamp: self blueRamp1 oriented: 0.65. pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35). pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35). buttons do: [ :each | each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0). ]. fileTypeButtons do: [ :each | each on: #mouseUp send: #value:value: to: [ :evt :morph | self update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph. ] fixTemps ]. buttons first on: #mouseUp send: #okHit to: aFileList. buttons second on: #mouseUp send: #cancelHit to: aFileList. aFileList postOpen. window position: aWorld topLeft + (aWorld extent - window extent // 2). aFileList directoryChangeBlock: [ :newDir | self enableTypeButtons: fileTypeButtons info: fileTypeInfo forDir: newDir ] fixTemps. aFileList directory: aFileList directory. window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). ^ window openInWorld: aWorld.! ! !FileList2 class methodsFor: 'blue ui' stamp: 'RAA 2/19/2001 10:14'! morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean ^self morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: #initialDirectoryList ! ! !FileList2 class methodsFor: 'blue ui' stamp: 'dgd 8/27/2004 18:33'! morphicViewProjectLoader2InWorld: aWorld reallyLoad: aBoolean dirFilterType: aSymbol | window aFileList buttons treePane textColor1 fileListPane pane2a pane2b treeExtent filesExtent | window _ AlignmentMorphBob1 newColumn. window hResizing: #shrinkWrap; vResizing: #shrinkWrap. textColor1 _ Color r: 0.742 g: 0.839 b: 1.0. aFileList _ self new directory: FileDirectory default. aFileList optionalButtonSpecs: aFileList servicesForProjectLoader; fileSelectionBlock: ( aSymbol == #limitedSuperSwikiDirectoryList ifTrue: [ MessageSend receiver: self selector: #projectOnlySelectionMethod: ] ifFalse: [ self projectOnlySelectionBlock ] ); "dirSelectionBlock: self hideSqueakletDirectoryBlock;" modalView: window. window setProperty: #FileList toValue: aFileList; wrapCentering: #center; cellPositioning: #topCenter; borderWidth: 4; borderColor: (Color r: 0.355 g: 0.516 b: 1.0); useRoundedCorners. buttons _ #('OK' 'Cancel') collect: [ :each | self blueButtonText: each textColor: textColor1 inWindow: window ]. aWorld width < 800 ifTrue: [ treeExtent _ 150@300. filesExtent _ 350@300. ] ifFalse: [ treeExtent _ 250@300. filesExtent _ 350@300. ]. (treePane _ aFileList morphicDirectoryTreePaneFiltered: aSymbol) extent: treeExtent; retractable: false; borderWidth: 0. fileListPane _ aFileList morphicFileListPane extent: filesExtent; retractable: false; borderWidth: 0. window addARow: { window fancyText: 'Load A Project' translated ofSize: 21 color: textColor1 }; addARowCentered: { buttons first. (Morph new extent: 30@5) color: Color transparent. buttons second }; addARow: { window fancyText: 'Please select a project' translated ofSize: 21 color: Color blue }; addARow: { (window inAColumn: {(pane2a _ window inARow: {window inAColumn: {treePane}}) useRoundedCorners; layoutInset: 6}) layoutInset: 10. (window inAColumn: {(pane2b _ window inARow: {window inAColumn: {fileListPane}}) useRoundedCorners; layoutInset: 6}) layoutInset: 10. }. window fullBounds. window fillWithRamp: self blueRamp1 oriented: 0.65. pane2a fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35). pane2b fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35). buttons do: [ :each | each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0). ]. buttons first on: #mouseUp send: (aBoolean ifTrue: [#okHitForProjectLoader] ifFalse: [#okHit]) to: aFileList. buttons second on: #mouseUp send: #cancelHit to: aFileList. aFileList postOpen. window position: aWorld topLeft + (aWorld extent - window extent // 2). window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). ^ window openInWorld: aWorld.! ! !FileList2 class methodsFor: 'blue ui' stamp: 'jm 9/2/2003 21:14'! morphicViewProjectSaverFor: aProject " (FileList2 morphicViewProjectSaverFor: Project current) openInWorld " | window aFileList buttons treePane pane2 textColor1 option treeExtent buttonData buttonRow | textColor1 _ Color r: 0.742 g: 0.839 b: 1.0. aFileList _ self new directory: ServerDirectory projectDefaultDirectory. aFileList dirSelectionBlock: self hideSqueakletDirectoryBlock. window _ AlignmentMorphBob1 newColumn. window hResizing: #shrinkWrap; vResizing: #shrinkWrap. aFileList modalView: window. window setProperty: #FileList toValue: aFileList; wrapCentering: #center; cellPositioning: #topCenter; borderWidth: 4; borderColor: (Color r: 0.355 g: 0.516 b: 1.0); useRoundedCorners. buttonData _ Preferences enableLocalSave ifTrue: [#( ('Save' okHit 'Save in the place specified below, and in the Squeaklets folder on your local disk') ('Save on local disk only' saveLocalOnlyHit 'saves in the Squeaklets folder') ('Cancel' cancelHit 'return without saving') )] ifFalse: [#( ('Save' okHit 'Save in the place specified below, and in the Squeaklets folder on your local disk') ('Cancel' cancelHit 'return without saving') )]. buttons _ buttonData collect: [ :each | (self blueButtonText: each first translated textColor: textColor1 inWindow: window) setBalloonText: each third translated; hResizing: #shrinkWrap; on: #mouseUp send: each second to: aFileList ]. option _ aProject world valueOfProperty: #SuperSwikiPublishOptions ifAbsent: [#initialDirectoryList]. aProject world removeProperty: #SuperSwikiPublishOptions. World height < 500 ifTrue: [ treeExtent _ 350@150. ] ifFalse: [ treeExtent _ 350@300. ]. (treePane _ aFileList morphicDirectoryTreePaneFiltered: option) extent: treeExtent; retractable: false; borderWidth: 0. window addARowCentered: { window fancyText: 'Publish This Project' translated ofSize: 21 color: textColor1 }. buttonRow _ OrderedCollection new. buttons do: [:button | buttonRow add: button] separatedBy: [buttonRow add: ((Morph new extent: 30@5) color: Color transparent)]. " addARowCentered: { buttons first. (Morph new extent: 30@5) color: Color transparent. buttons second. (Morph new extent: 30@5) color: Color transparent. buttons third };" window addARowCentered: buttonRow; addARowCentered: { (window inAColumn: {(ProjectViewMorph on: aProject) lock}) layoutInset: 4}; addARowCentered: { window fancyText: 'Please select a folder' translated ofSize: 21 color: Color blue }; addARow: { ( window inAColumn: { (pane2 _ window inARow: {window inAColumn: {treePane}}) useRoundedCorners; layoutInset: 6 } ) layoutInset: 10 }. window fullBounds. window fillWithRamp: self blueRamp1 oriented: 0.65. pane2 fillWithRamp: self blueRamp3 oriented: (0.7 @ 0.35). buttons do: [ :each | each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0). ]. window setProperty: #morphicLayerNumber toValue: 11. aFileList postOpen. window adoptPaneColor: (Color r: 0.548 g: 0.677 b: 1.0). ^ window ! ! !FileList2 class methodsFor: 'instance creation' stamp: 'nk 7/12/2000 11:03'! openMorphicViewInWorld "FileList2 openMorphicViewInWorld" ^self morphicView openInWorld! ! !FileList2 class methodsFor: 'instance creation' stamp: 'nk 6/14/2004 08:41'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" ^ self morphicView applyModelExtent! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02'! modalFileSelector | window | window _ self morphicViewFileSelector. window openCenteredInWorld. [window world notNil] whileTrue: [ window outermostWorldMorph doOneCycle. ]. ^(window valueOfProperty: #fileListModel) getSelectedFile! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02'! modalFileSelectorForSuffixes: aList | window aFileList | window _ self morphicViewFileSelectorForSuffixes: aList. aFileList _ window valueOfProperty: #fileListModel. window openCenteredInWorld. [window world notNil] whileTrue: [ window outermostWorldMorph doOneCycle. ]. ^aFileList getSelectedFile! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'gh 9/16/2002 10:33'! modalFolderSelector ^self modalFolderSelector: FileDirectory default! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02'! modalFolderSelector: aDir | window fileModel | window _ self morphicViewFolderSelector: aDir. fileModel _ window model. window openInWorld: self currentWorld extent: 300@400. [window world notNil] whileTrue: [ window outermostWorldMorph doOneCycle. ]. ^fileModel getSelectedDirectory withoutListWrapper! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02'! modalFolderSelectorForProject: aProject " FileList2 modalFolderSelectorForProject: Project current " | window fileModel w | window _ FileList2 morphicViewProjectSaverFor: aProject. fileModel _ window valueOfProperty: #FileList. w _ self currentWorld. window position: w topLeft + (w extent - window extent // 2). w addMorphInLayer: window. w startSteppingSubmorphsOf: window. [window world notNil] whileTrue: [ window outermostWorldMorph doOneCycle. ]. ^fileModel getSelectedDirectory withoutListWrapper! ! !FileList2 class methodsFor: 'modal dialogs' stamp: 'nk 5/8/2003 19:02'! modalFolderSelectorForProjectLoad | window fileModel w | window _ self morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false. fileModel _ window valueOfProperty: #FileList. w _ self currentWorld. window position: w topLeft + (w extent - window extent // 2). window openInWorld: w. [window world notNil] whileTrue: [ window outermostWorldMorph doOneCycle. ]. ^fileModel getSelectedDirectory withoutListWrapper! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'RAA 3/6/2001 12:47'! morphicViewFileSelector ^self morphicViewFileSelectorForSuffixes: nil ! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'dgd 9/19/2003 12:18'! morphicViewFileSelectorForSuffixes: aList "Answer a morphic file-selector tool for the given suffix list" | dir aFileList window fixedSize midLine gap | dir _ FileDirectory default. aFileList _ self new directory: dir. aFileList optionalButtonSpecs: aFileList okayAndCancelServices. aList ifNotNil: [aFileList fileSelectionBlock: [:entry :myPattern | entry isDirectory ifTrue: [false] ifFalse: [aList includes: (FileDirectory extensionFor: entry name asLowercase)]] fixTemps]. window _ BorderedMorph new layoutPolicy: ProportionalLayout new; color: Color lightBlue; borderColor: Color blue; borderWidth: 4; layoutInset: 4; extent: 600@400; useRoundedCorners. window setProperty: #fileListModel toValue: aFileList. aFileList modalView: window. midLine _ 0.4. fixedSize _ 25. gap _ 5. self addFullPanesTo: window from: { {self textRow: 'Please select a file' translated. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}. {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@fixedSize corner: 0@(fixedSize * 2)}. {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. gap @(fixedSize * 2) corner: gap negated@0}. {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. gap@(fixedSize * 2) corner: gap negated@0}. }. aFileList postOpen. ^ window ! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'gh 9/16/2002 10:30'! morphicViewFolderSelector ^self morphicViewFolderSelector: FileDirectory default! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'bkv 11/12/2002 16:55'! morphicViewFolderSelector: aDir "Answer a tool that allows the user to select a folder" | aFileList window fixedSize | aFileList _ self new directory: aDir. aFileList optionalButtonSpecs: aFileList servicesForFolderSelector. window _ (SystemWindow labelled: aDir pathName) model: aFileList. aFileList modalView: window. fixedSize _ 25. self addFullPanesTo: window from: { {self textRow: 'Please select a folder'. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}. {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@fixedSize corner: 0@(fixedSize * 2)}. {aFileList morphicDirectoryTreePane. 0@0 corner: 1@1. 0@(fixedSize * 2) corner: 0@0}. }. aFileList postOpen. ^ window ! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'sw 2/22/2002 02:02'! morphicViewProjectLoader | dir aFileList window midLine fixedSize | dir _ FileDirectory default. aFileList _ self new directory: dir. aFileList optionalButtonSpecs: aFileList servicesForProjectLoader. aFileList fileSelectionBlock: self projectOnlySelectionBlock. window _ (SystemWindow labelled: dir pathName) model: aFileList. fixedSize _ 25. midLine _ 0.4. self addFullPanesTo: window from: { {aFileList optionalButtonRow. 0 @ 0 corner: 1 @ 0. 0@0 corner: 0@fixedSize}. {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}. {aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}. }. aFileList postOpen. ^ window ! ! !FileList2 class methodsFor: 'morphic ui' stamp: 'yo 3/15/2005 12:36'! update: actionRow in: window fileTypeRow: fileTypeRow morphUp: morph | fileTypeInfo info2 buttons textColor1 fileSuffixes fileActions aFileList fileTypeString | (morph valueOfProperty: #enabled) ifFalse: [^self]. fileTypeRow submorphsDo: [ :sub | sub color: ( sub == morph ifTrue: [Color white] ifFalse: [(sub valueOfProperty: #enabled) ifTrue: [Color transparent] ifFalse: [Color gray]] ). ]. fileTypeString _ morph valueOfProperty: #buttonText. aFileList _ window valueOfProperty: #FileList. textColor1 _ Color r: 0.742 g: 0.839 b: 1.0. actionRow removeAllMorphs. fileTypeInfo _ self endingSpecs. info2 _ fileTypeInfo detect: [ :each | each first = fileTypeString] ifNone: [self error: 'bad fileTypeString' ]. fileSuffixes _ info2 second. fileActions _ info2 third. buttons _ fileActions collect: [ :each | aFileList blueButtonForService: each textColor: textColor1 inWindow: window ]. buttons addLast: (self blueButtonText: 'Cancel' textColor: textColor1 inWindow: window balloonText: 'Cancel this search' translated selector: #cancelHit recipient: aFileList). buttons do: [ :each | actionRow addMorphBack: each]. window fullBounds. buttons do: [ :each | each fillWithRamp: self blueRamp2 oriented: (0.75 @ 0). ]. aFileList fileSelectionBlock: ( self selectionBlockForSuffixes: (fileSuffixes collect: [ :each | '*.',each]) ). aFileList updateFileList. ! ! !FileList2 class methodsFor: 'utility' stamp: 'RAA 3/6/2001 12:39'! textRow: aString ^AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter; color: Color transparent; layoutInset: 0; addMorph: ( AlignmentMorph newColumn wrapCentering: #center; cellPositioning: #topCenter; color: Color transparent; vResizing: #shrinkWrap; layoutInset: 0; addMorph: ( AlignmentMorph newRow wrapCentering: #center; cellPositioning: #leftCenter; color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0; addMorph: ((StringMorph contents: aString) color: Color blue; lock) ) )! ! !FileList2 class methodsFor: 'preferences' stamp: 'kfr 6/20/2004 16:36'! useFileList2preferenceChanged | preferred quads registered | preferred := Preferences useFileList2 ifTrue: [#FileList2] ifFalse: [#FileList]. quads := Flaps registeredFlapsQuads at: 'Tools' ifAbsent: [^ self]. registered := quads detect: [:quad | quad first beginsWith: 'FileList'] ifNone: [Flaps registerQuad: { preferred. #prototypicalToolWindow. 'File List'. 'A File List is a tool for browsing folders and files on disks and FTP servers.'} forFlapNamed: 'Tools'. nil]. registered ifNotNil: [registered at: 1 put: preferred]. Flaps replaceToolsFlap! ! !FileList2 class methodsFor: '*smloader-override' stamp: 'btr 1/30/2004 00:56'! morphicView ^ self morphicViewOnDirectory: FileDirectory default! ! !FileList2 class methodsFor: '*smloader-extension' stamp: 'btr 1/30/2004 00:56'! morphicViewOnDirectory: aFileDirectory | aFileList window fileListBottom midLine fileListTopOffset buttonPane | aFileList _ self new directory: aFileDirectory. window _ (SystemWindow labelled: aFileDirectory pathName) model: aFileList. fileListTopOffset _ (TextStyle defaultFont pointSize * 2) + 14. fileListBottom _ 0.4. midLine _ 0.4. buttonPane _ aFileList optionalButtonRow addMorph: (aFileList morphicPatternPane vResizing: #spaceFill; yourself). self addFullPanesTo: window from: { {buttonPane. 0@0 corner: 1@0. 0@0 corner: 0@fileListTopOffset}. {aFileList morphicDirectoryTreePane. 0@0 corner: midLine@fileListBottom. 0@fileListTopOffset corner: 0@0}. {aFileList morphicFileListPane. midLine @ 0 corner: 1@fileListBottom. 0@fileListTopOffset corner: 0@0}. {aFileList morphicFileContentsPane. 0@fileListBottom corner: 1@1. nil}. }. aFileList postOpen. ^ window ! ! !FileList2ModalDialogsTest methodsFor: 'running' stamp: 'LC 1/6/2002 08:45'! testModalFileSelector | window fileList2 | window _ FileList2 morphicViewFileSelector. window openCenteredInWorld. fileList2 _ window valueOfProperty: #fileListModel. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedFile isNil. fileList2 okHit. self deny: fileList2 getSelectedFile isNil ! ! !FileList2ModalDialogsTest methodsFor: 'running' stamp: 'LC 1/6/2002 08:50'! testModalFileSelectorForSuffixes | window fileList2 | window _ FileList2 morphicViewFileSelectorForSuffixes: nil. window openCenteredInWorld. fileList2 _ window valueOfProperty: #fileListModel. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedFile isNil. fileList2 okHit. self deny: fileList2 getSelectedFile isNil ! ! !FileList2ModalDialogsTest methodsFor: 'running' stamp: 'LC 1/6/2002 08:55'! testModalFolderSelector | window fileList2 | window _ FileList2 morphicViewFolderSelector. fileList2 _ window model. window openInWorld: self currentWorld extent: 300@400. fileList2 fileListIndex: 1. window delete. self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. fileList2 okHit. self deny: fileList2 getSelectedDirectory withoutListWrapper isNil ! ! !FileList2ModalDialogsTest methodsFor: 'running' stamp: 'LC 1/6/2002 09:01'! testModalFolderSelectorForProjectLoad | window fileList2 w | window _ FileList2 morphicViewProjectLoader2InWorld: self currentWorld reallyLoad: false. fileList2 _ window valueOfProperty: #FileList. w _ self currentWorld. window position: w topLeft + (w extent - window extent // 2). window openInWorld: w. window delete. self assert: fileList2 getSelectedDirectory withoutListWrapper isNil. fileList2 okHit. self deny: fileList2 getSelectedDirectory withoutListWrapper isNil ! ! !FileList2ModalDialogsTest commentStamp: '' prior: 0! TestRunner open! !FileListTest methodsFor: 'private' stamp: 'sd 2/1/2002 23:04'! checkIsServiceIsFromDummyTool: service ^ (service instVarNamed: #provider) = DummyToolWorkingWithFileList & service label = 'menu label' & (service instVarNamed: #selector) = #loadAFileForTheDummyTool:! ! !FileListTest methodsFor: 'initialize' stamp: 'SD 11/10/2001 21:48'! setUp DummyToolWorkingWithFileList initialize.! ! !FileListTest methodsFor: 'initialize' stamp: 'SD 11/10/2001 21:49'! tearDown DummyToolWorkingWithFileList unregister.! ! !FileListTest methodsFor: 'test' stamp: 'SD 11/10/2001 21:53'! testMenuReturned "(self selector: #testToolRegistered) debug" self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! ! !FileListTest methodsFor: 'test' stamp: 'sd 2/6/2002 21:26'! testService "a stupid test to check that the class returns a service" "(self selector: #testService) debug" | service | service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'abab.kkk' suffix: 'kkk') first. self assert: (self checkIsServiceIsFromDummyTool: service). service := (DummyToolWorkingWithFileList fileReaderServicesForFile: 'zkk.gz' suffix: 'gz'). self assert: service isEmpty! ! !FileListTest methodsFor: 'test' stamp: 'nk 11/30/2002 14:55'! testServicesForFileEnding "(self selector: #testServicesForFileEnding) debug" self assert: (((FileList new directory: FileDirectory default; yourself) itemsForFile: 'aaa.kkk') anySatisfy: [ :ea | self checkIsServiceIsFromDummyTool: ea ]). ! ! !FileListTest methodsFor: 'test' stamp: 'SD 11/10/2001 21:52'! testToolRegistered "(self selector: #testToolRegistered) debug" self assert: (FileList registeredFileReaderClasses includes: DummyToolWorkingWithFileList)! ! !FileListTest methodsFor: 'test' stamp: 'SD 11/11/2001 13:54'! testToolRegisteredUsingInterface "(self selector: #testToolRegisteredUsingInterface) debug" self assert: (FileList isReaderNamedRegistered: #DummyToolWorkingWithFileList)! ! !FileModifyingSimpleServiceEntry methodsFor: 'as yet unclassified' stamp: 'nk 11/26/2002 12:08'! performServiceFor: anObject | retval | retval _ super performServiceFor: anObject. self changed: #fileListChanged. ^retval "is this used anywhere?"! ! !FileModifyingSimpleServiceEntry commentStamp: 'nk 11/26/2002 12:03' prior: 0! I represent a service that may change the contents of a directory. Such changes include: * file creation * file deletion * file modification! !FilePackage methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:31'! fixClassOrder "Essentially bubble sort the classOrder so that superclasses appear before subclasses" | superClass index subClass superIndex | index := 0. [index < classOrder size] whileTrue:[ subClass := classOrder at: (index := index + 1). superClass := nil. subClass isMeta ifTrue:[ "Treat non-meta as superclass" superClass := self classes at: subClass name ifAbsent:[nil]. ] ifFalse:[ subClass hasDefinition ifTrue:[ superClass := self classes at: (Scanner new scanTokens: subClass definition) first ifAbsent:[nil]. superClass ifNotNil:[superClass hasDefinition ifFalse:[superClass := nil]]. ]. ]. superClass ifNotNil:[ superIndex := classOrder indexOf: superClass ifAbsent:[self error:'Where is the class?']. superIndex > index ifTrue:[ "Move superClass before index" classOrder remove: superClass. classOrder add: superClass before: subClass. "Rewind index - we need to check superClass itself" index := index - 1. ]. ]. ]. ! ! !FilePackage methodsFor: 'accessing' stamp: 'ar 2/5/2004 15:11'! removeDoIts doIts := OrderedCollection new.! ! !FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:53'! fromFileNamed: aName | stream | fullName := aName. stream := FileStream readOnlyFileNamed: aName. stream setConverterForCode. [self fileInFrom: stream] ensure:[stream close].! ! !FilePackage methodsFor: 'initialize' stamp: 'yo 8/17/2004 09:54'! fromFileNamed: aName encoding: encodingName | stream | fullName := aName. stream := FileStream readOnlyFileNamed: aName. stream converter: (TextConverter newForEncoding: encodingName). self fileInFrom: stream.! ! !FilePackage methodsFor: 'fileIn/fileOut' stamp: 'tk 3/7/2001 13:57'! fileOut | fileName stream | fileName := FillInTheBlank request: 'Enter the file name' initialAnswer:''. stream := FileStream newFileNamed: fileName. sourceSystem isEmpty ifFalse:[ stream nextChunkPut: sourceSystem printString;cr ]. self fileOutOn: stream. stream cr; cr. self classes do:[:cls| cls needsInitialize ifTrue:[ stream cr; nextChunkPut: cls name,' initialize']]. stream cr. stream close. "DeepCopier new checkVariables." ! ! !FilePath methodsFor: 'file in/out' stamp: 'yo 2/24/2005 18:41'! convertToCurrentVersion: varDict refStream: smartRefStrm "If we're reading in an old version with a system path instance variable, convert it to a vm path." varDict at: 'systemPathName' ifPresent: [ :x | vmPathName _ x. ]. ^super convertToCurrentVersion: varDict refStream: smartRefStrm. ! ! !FilePath methodsFor: 'file in/out' stamp: 'yo 2/24/2005 18:43'! copySystemToVm (self class instVarNames includes: 'systemPathName') ifTrue: [ vmPathName _ self instVarNamed: 'systemPathName'. ]. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:10'! asSqueakPathName ^ self pathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'ar 1/31/2005 11:16'! asString ^self asSqueakPathName! ! !FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'! asVmPathName ^ vmPathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'! coverter: aTextConverter converter class ~= aTextConverter class ifTrue: [ converter _ aTextConverter. vmPathName _ squeakPathName convertToWithConverter: converter ]. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! pathName ^ squeakPathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'! pathName: p isEncoded: isEncoded converter _ LanguageEnvironment defaultFileNameConverter. isEncoded ifTrue: [ squeakPathName _ p convertFromWithConverter: converter. vmPathName _ p. ] ifFalse: [ squeakPathName _ p isOctetString ifTrue: [p asOctetString] ifFalse: [p]. vmPathName _ squeakPathName convertToWithConverter: converter. ]. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! printOn: aStream aStream nextPutAll: 'FilePath('''. aStream nextPutAll: squeakPathName. aStream nextPutAll: ''')'. ! ! !FilePath methodsFor: 'testing' stamp: 'tpr 11/5/2004 11:39'! isNullPath "an empty path is used to represent the root path(s) when calling the primitive to list directory entries. Some users need to check for this and this is cleaner than grabbing the pathname and assuming it is a plain String" ^self pathName isEmpty! ! !FilePath commentStamp: 'yo 10/19/2004 21:36' prior: 0! This class absorb the difference of internal and external representation of the file path. The idea is to keep the internal one as much as possible, and only when it goes to a primitive, the encoded file path, i.e. the native platform representation is passsed to the primitive. The converter used is obtained by "LanguageEnvironment defaultFileNameConverter". ! !FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! pathName: pathName ^ self pathName: pathName isEncoded: false. ! ! !FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! pathName: pathName isEncoded: aBoolean ^ (self new) pathName: pathName isEncoded: aBoolean; yourself. ! ! !FilePath class methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 18:38'! classVersion ^ 1. ! ! !FileStream methodsFor: 'accessing' stamp: 'ar 8/6/2001 18:34'! contents "Return the contents of the receiver. Do not close or otherwise touch the receiver. Return data in whatever mode the receiver is in (e.g., binary or text)." | s savePos | savePos _ self position. self position: 0. s _ self next: self size. self position: savePos. ^s! ! !FileStream methodsFor: 'accessing' stamp: 'nk 2/22/2001 17:07'! directoryEntry ^self directory entryAt: self localName! ! !FileStream methodsFor: 'accessing'! next (position >= readLimit and: [self atEnd]) ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !FileStream methodsFor: 'positioning' stamp: 'JMM 5/24/2001 22:58'! truncate: pos "Truncate file to pos" self subclassResponsibility! ! !FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:12'! longPrintOn: aStream "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." ! ! !FileStream methodsFor: 'printing' stamp: 'tk 12/5/2001 09:32'! longPrintOn: aStream limitedTo: sizeLimit indent: indent "Do nothing, so it will print short. Called to print the error file. If the error was in a file operation, we can't read the contents of that file. Just print its name instead." aStream cr! ! !FileStream methodsFor: 'editing' stamp: 'sw 3/11/2002 22:42'! viewGZipContents "View the contents of a gzipped file" | stringContents | self binary. stringContents _ self contentsOfEntireFile. Cursor wait showWhile: [stringContents _ (GZipReadStream on: stringContents) upToEnd]. stringContents _ stringContents asString withSqueakLineEndings. Workspace new contents: stringContents; openLabel: 'Decompressed contents of: ', self localName! ! !FileStream methodsFor: 'file modes' stamp: 'mir 8/24/2004 17:58'! readOnlyStream ^self readOnly! ! !FileStream methodsFor: 'file accessing' stamp: 'gk 2/10/2004 13:21'! asUrl "Convert my path into a file:// type url - a FileUrl." ^FileUrl pathParts: (self directory pathParts copyWith: self localName)! ! !FileStream methodsFor: 'file accessing' stamp: 'gk 2/10/2004 13:21'! url "Convert my path into a file:// type url String." ^self asUrl toText! ! !FileStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:42'! fileIn "Guarantee that the receiver is readOnly before fileIn for efficiency and to eliminate remote sharing conflicts." self readOnly. self fileInAnnouncing: 'Loading ', self localName! ! !FileStream methodsFor: 'fileIn/Out' stamp: 'di 10/31/2001 12:07'! fileIntoNewChangeSet "File all of my contents into a new change set." self readOnly. ChangeSorter newChangesFromStream: self named: (self localName) ! ! !FileStream commentStamp: '' prior: 0! I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated. To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance. *** On DOS, files cannot be shortened!! *** To overwrite a file with a shorter one, first delete the old file (FileDirectory deleteFilePath: 'Hard Disk:aFolder:dataFolder:foo') or (aFileDirectory deleteFileNamed: 'foo'). Then write your new shorter version.! !FileStream class methodsFor: 'instance creation' stamp: 'tpr 10/16/2001 12:49'! forceNewFileNamed: fileName "Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, delete it without asking before creating the new file." ^self concreteStream forceNewFileNamed: fileName! ! !FileStream class methodsFor: 'concrete classes' stamp: 'yo 7/5/2004 20:18'! concreteStream "Who should we really direct class queries to? " ^ MultiByteFileStream. ! ! !FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 16:58'! httpPostDocument: url args: argsDict | argString | argString _ argsDict ifNotNil: [argString _ HTTPSocket argString: argsDict] ifNil: ['']. ^self post: argString url: url , argString ifError: [self halt]! ! !FileStream class methodsFor: 'browser requests' stamp: 'mir 5/13/2003 10:43'! httpPostMultipart: url args: argsDict | mimeBorder argsStream crLf fieldValue resultStream result | " do multipart/form-data encoding rather than x-www-urlencoded " crLf _ String crlf. mimeBorder _ '----squeak-', Time millisecondClockValue printString, '-stuff-----'. "encode the arguments dictionary" argsStream _ WriteStream on: String new. argsDict associationsDo: [:assoc | assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, crLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue _ value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType. fieldValue _ (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: crLf, crLf, fieldValue, crLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. resultStream _ self post: ('Content-type: multipart/form-data; boundary=', mimeBorder, crLf, 'Content-length: ', argsStream contents size printString, crLf, crLf, argsStream contents) url: url ifError: [^'Error in post ' url toText]. "get the header of the reply" result _ resultStream upToEnd. ^MIMEDocument content: result! ! !FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'! post: data target: target url: url ifError: errorBlock ^self concreteStream new post: data target: target url: url ifError: errorBlock! ! !FileStream class methodsFor: 'browser requests' stamp: 'mir 2/2/2001 14:23'! post: data url: url ifError: errorBlock ^self post: data target: nil url: url ifError: errorBlock! ! !FileStream class methodsFor: 'browser requests' stamp: 'mir 4/30/2001 18:32'! requestURL: url target: target "FileStream requestURL:'http://isgwww.cs.uni-magdeburg.de/~raab' target: '_blank' " ^self concreteStream new requestURL: url target: target! ! !FileStream class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 18:00'! initialize FileList registerFileReader: self! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! cs ^ 'cs' clone. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 8/18/2004 20:24'! fileIn: fullName "File in the entire contents of the file specified by the name provided" | ff | fullName ifNil: [^ Beeper beep]. ff _ self readOnlyFileNamed: (GZipReadStream uncompressedFileName: fullName). ff fileIn. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'nk 7/16/2003 15:49'! fileReaderServicesForFile: fullName suffix: suffix "Answer services for the given file" ^ ((self isSourceFileSuffix: suffix) or: [ suffix = '*' ]) ifTrue: [{self serviceRemoveLineFeeds. self serviceFileIn}] ifFalse: [#()]! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 20:18'! isSourceFileSuffix: suffix ^ (FileStream sourceFileSuffixes includes: suffix) or: [suffix = '*']. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:00'! multiCs ^ 'mcs' clone. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! multiSt ^ 'mst' clone. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/31/2004 18:04'! removeLineFeeds: fullName | fileContents | fileContents _ ((FileStream readOnlyFileNamed: fullName) wantsLineEndConversion: true) contentsOfEntireFile. (FileStream newFileNamed: fullName) nextPutAll: fileContents; close.! ! !FileStream class methodsFor: 'file reader services' stamp: 'sw 2/17/2002 01:38'! serviceFileIn "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'fileIn entire file' selector: #fileIn: description: 'file in the entire contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' buttonLabel: 'filein'! ! !FileStream class methodsFor: 'file reader services' stamp: 'nk 11/26/2002 12:49'! serviceRemoveLineFeeds "Answer a service for removing linefeeds from a file" ^ FileModifyingSimpleServiceEntry provider: self label: 'remove line feeds' selector: #removeLineFeeds: description: 'remove line feeds in file' buttonLabel: 'remove lfs'! ! !FileStream class methodsFor: 'file reader services' stamp: 'sd 2/1/2002 22:28'! services ^ Array with: self serviceRemoveLineFeeds with: self serviceFileIn ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/7/2004 09:43'! sourceFileSuffixes ^ {FileStream st. FileStream cs. FileStream multiSt. FileStream multiCs} asSet asArray. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'yo 7/5/2004 21:01'! st ^ 'st' clone. ! ! !FileStream class methodsFor: 'file reader services' stamp: 'tak 1/12/2005 14:59'! writeSourceCodeFrom: aStream baseName: baseName isSt: stOrCsFlag useHtml: useHtml | extension converter f fileName | aStream contents isAsciiString ifTrue: [ stOrCsFlag ifTrue: [ extension _ (FileDirectory dot, FileStream st). ] ifFalse: [ extension _ (FileDirectory dot, FileStream cs). ]. converter _ MacRomanTextConverter new. ] ifFalse: [ stOrCsFlag ifTrue: [ extension _ (FileDirectory dot, FileStream st "multiSt"). ] ifFalse: [ extension _ (FileDirectory dot, FileStream cs "multiCs"). ]. converter _ UTF8TextConverter new. ]. fileName _ useHtml ifTrue: [baseName, '.html'] ifFalse: [baseName, extension]. f _ FileStream newFileNamed: fileName. f ifNil: [^ self error: 'Cannot open file']. (converter isMemberOf: UTF8TextConverter) ifTrue: [f binary. UTF8TextConverter writeBOMOn: f]. f text. f converter: converter. f nextPutAll: aStream contents. f close. ! ! !FileStream class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !FileUrl methodsFor: 'printing' stamp: 'gk 2/10/2004 10:49'! toText "Return the FileUrl according to RFC1738 plus supporting fragments: 'file:///#' Note that being '' is equivalent to 'localhost'. Note: The pathString can not start with a leading $/ to indicate an 'absolute' file path. This is not according to RFC1738 where the path should have no leading or trailing slashes, and always be considered absolute relative to the filesystem." ^String streamContents: [:s | s nextPutAll: self schemeName, '://'. host ifNotNil: [s nextPutAll: host]. s nextPut: $/; nextPutAll: self pathString. fragment ifNotNil: [ s nextPut: $#; nextPutAll: fragment encodeForHTTP ]]! ! !FileUrl methodsFor: 'testing' stamp: 'gk 2/9/2004 20:32'! firstPartIsDriveLetter "Return true if the first part of the path is a letter followed by a $: like 'C:' " | firstPart | path isEmpty ifTrue: [^false]. firstPart _ path first. ^firstPart size = 2 and: [ firstPart first isLetter and: [firstPart last = $:]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! pathDirString "Path to directory as url, using slash as delimiter. Filename is left out." ^String streamContents: [ :s | isAbsolute ifTrue: [ s nextPut: $/ ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: $/]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! pathForDirectory "Path using local file system's delimiter. $\ or $: DOS paths with drive letters should not be prepended with a pathNameDelimiter even though they are absolute. Filename is left out." ^String streamContents: [ :s | (self isAbsolute and: [self firstPartIsDriveLetter not]) ifTrue: [ s nextPut: $/ ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: FileDirectory default pathNameDelimiter]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 10:22'! pathString "Path as it appears in a URL with $/ as delimiter." | first | ^String streamContents: [ :s | "isAbsolute ifTrue:[ s nextPut: $/ ]." first _ true. self path do: [ :p | first ifFalse: [ s nextPut: $/ ]. first _ false. s nextPutAll: p encodeForHTTP ] ]! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:16'! host "Return the host name, either 'localhost', '', or a fully qualified domain name." ^host ifNil: ['']! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/12/2004 16:22'! host: hostName "Set the host name, either 'localhost', '', or a fully qualified domain name." host _ hostName! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:50'! isAbsolute: aBoolean isAbsolute _ aBoolean! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15'! path "Return an ordered collection of the path elements." ^path! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:16'! path: anArray "Set the collection of path elements." path _ anArray! ! !FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 13:06'! default "Use the default local Squeak file directory." | local | local _ self class pathParts: (FileDirectory default pathParts), #('') isAbsolute: true. self privateInitializeFromText: self pathString relativeTo: local. "sets absolute also"! ! !FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 00:50'! retrieveContents | file pathString s type entries | pathString _ self pathForFile. file _ [FileStream readOnlyFileNamed: pathString] on: FileDoesNotExistException do:[:ex| ex return: nil]. file ifNotNil: [ type _ file mimeTypes. type ifNotNil:[type _ type first]. type ifNil:[MIMEDocument guessTypeFromName: self path last]. ^MIMELocalFileDocument contentType: type contentStream: file]. "see if it's a directory..." entries _ [(FileDirectory on: pathString) entries] on: InvalidDirectoryError do:[:ex| ex return: nil]. entries ifNil:[^nil]. s _ WriteStream on: String new. (pathString endsWith: '/') ifFalse: [ pathString _ pathString, '/' ]. s nextPutAll: 'Directory Listing for ', pathString, ''. s nextPutAll: '

Directory Listing for ', pathString, '

'. s nextPutAll: ''. ^MIMEDocument contentType: 'text/html' content: s contents url: ('file://', pathString)! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:05'! host: aHostString pathParts: aCollection isAbsolute: aBoolean host _ aHostString. path _ aCollection. isAbsolute _ aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:01'! initializeFromPathString: aPathString " is a file path as a String. We construct a path collection using various heuristics." | pathString hasDriveLetter | pathString _ aPathString. pathString isEmpty ifTrue: [pathString _ '/']. path _ (pathString findTokens: '/') collect: [:token | token unescapePercents]. "A path like 'C:' refers in practice to 'c:/'" ((pathString endsWith: '/') or: [(hasDriveLetter _ self firstPartIsDriveLetter) and: [path size = 1]]) ifTrue: [path add: '']. "Decide if we are absolute by checking for leading $/ or beginning with drive letter. Smarts for other OSes?" self isAbsolute: ((pathString beginsWith: '/') or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:04'! pathParts: aCollection isAbsolute: aBoolean ^self host: nil pathParts: aCollection isAbsolute: aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:11'! privateInitializeFromText: aString "Calculate host and path from a file URL in String format. Some malformed formats are allowed and interpreted by guessing." | schemeName pathString bare hasDriveLetter stream char i | bare _ aString withBlanksTrimmed. schemeName _ Url schemeNameForString: bare. (schemeName isNil or: [schemeName ~= self schemeName]) ifTrue: [ host _ ''. pathString _ bare] ifFalse: [ "First remove schemeName and colon" bare _ bare copyFrom: (schemeName size + 2) to: bare size. "A proper file URL then has two slashes before host, A malformed URL is interpreted as using syntax file:." (bare beginsWith: '//') ifTrue: [i _ bare indexOf: $/ startingAt: 3. i=0 ifTrue: [ host _ bare copyFrom: 3 to: bare size. pathString _ ''] ifFalse: [ host _ bare copyFrom: 3 to: i-1. pathString _ bare copyFrom: host size + 3 to: bare size]] ifFalse: [host _ ''. pathString _ bare]]. self initializeFromPathString: pathString ! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:29'! privateInitializeFromText: pathString relativeTo: aUrl " should be a filesystem path. This url is adjusted to be aUrl + the path." | bare newPath | self host: aUrl host. self initializeFromPathString: pathString. self isAbsolute: aUrl isAbsolute. newPath _ aUrl path copy. newPath removeLast. "empty string that says its a directory" path do: [ :token | ((token ~= '..') and: [token ~= '.']) ifTrue: [ newPath addLast: token unescapePercents ]. token = '..' ifTrue: [ newPath isEmpty ifFalse: [ newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. "token = '.' do nothing" ]. path _ newPath ! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! scheme ^self class schemeName! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! schemeName ^self class schemeName! ! !FileUrl methodsFor: 'copying' stamp: 'gk 2/10/2004 09:52'! copy "Be sure not to share the path with the copy" ^(self clone) path: path copy! ! !FileUrl methodsFor: 'access' stamp: 'ar 10/13/2004 17:54'! pathForFile "Path using local file system's delimiter. $\ or $:" ^FileDirectory default pathFromUrl: self! ! !FileUrl commentStamp: 'gk 2/10/2004 10:56' prior: 0! This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt Here is the relevant part of the RFC: 3.10 FILES The file URL scheme is used to designate files accessible on a particular host computer. This scheme, unlike most other URL schemes, does not designate a resource that is universally accessible over the Internet. A file URL takes the form: file:/// where is the fully qualified domain name of the system on which the is accessible, and is a hierarchical directory path of the form //.../. For example, a VMS file DISK$USER:[MY.NOTES]NOTE123456.TXT might become As a special case, can be the string "localhost" or the empty string; this is interpreted as `the machine from which the URL is being interpreted'. The file URL scheme is unusual in that it does not specify an Internet protocol or access method for such files; as such, its utility in network protocols between hosts is limited. From the above we can conclude that the RFC says that the part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly. The path is stored as a SequenceableCollection of path parts. Notes regarding non RFC features in this class: - If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown when sent #toText with a trailing slash. - The FileUrl has an attribute isAbsolute which refers to if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that. - Fragment is supported (kept for historical reasons) ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 12:16'! absoluteFromText: aString "Method that can be called explicitly to create a FileUrl." ^self new privateInitializeFromText: aString! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:04'! host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean "Create a FileUrl." ^self new host: aHost pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:10'! pathParts: aCollectionOfPathParts "Create a FileUrl." ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: true! ! !FileUrl class methodsFor: 'instance creation' stamp: 'gk 2/10/2004 13:06'! pathParts: aCollectionOfPathParts isAbsolute: aBoolean "Create a FileUrl." ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! !FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'! schemeName ^'file'! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer nil if the user cancels. An empty string returned means that the ussr cleared the editing area and then hit 'accept'. Because multiple lines are invited, we ask that the user use the ENTER key, or (in morphic anyway) hit the 'accept' button, to submit; that way, the return key can be typed to move to the next line. NOTE: The ENTER key does not work on Windows platforms." "FillInTheBlank multiLineRequest: 'Enter several lines; end input by accepting or canceling via menu or press Alt+s/Alt+l' centerAt: Display center initialAnswer: 'Once upon a time...' answerHeight: 200" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: self currentWorld onCancelReturn: nil acceptOnCR: false]. model := self new. model contents: defaultAnswer. model responseUponCancel: nil. model acceptOnCR: false. fillInView := self fillInTheBlankViewClass multiLineOn: model message: queryString centerAt: aPoint answerHeight: answerHeight. ^model show: fillInView! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:53'! request: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'Your name?'" ^ self request: queryString initialAnswer: '' centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! request: queryString initialAnswer: defaultAnswer "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'What is your favorite color?' initialAnswer: 'red, no blue. Ahhh!!'" ^ self request: queryString initialAnswer: defaultAnswer centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass request: queryString initialAnswer: defaultAnswer centerAt: aPoint]. model := self new. model contents: defaultAnswer. fillInView := self fillInTheBlankViewClass on: model message: queryString centerAt: aPoint. ^model show: fillInView! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! requestPassword: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank requestPassword: 'POP password'" | model fillInView | Smalltalk isMorphic ifTrue: [^self fillInTheBlankMorphClass requestPassword: queryString]. model := self new. model contents: ''. fillInView := self fillInTheBlankViewClass requestPassword: model message: queryString centerAt: Sensor cursorPoint answerHeight: 40. ^model show: fillInView! ! !FillInTheBlankController methodsFor: 'basic control sequence' stamp: 'th 9/17/2002 16:46'! controlInitialize model acceptOnCR ifFalse: [^ super controlInitialize]. self setMark: self markBlock stringIndex. self setPoint: self pointBlock stringIndex. self initializeSelection. beginTypeInBlock _ nil. ! ! !FillInTheBlankMorph methodsFor: 'event handling' stamp: 'md 10/22/2003 16:20'! mouseDown: evt (self containsPoint: evt position) ifFalse:[^ Beeper beep]. "sent in response to outside modal click" evt hand grabMorph: self. "allow repositioning"! ! !FillInTheBlankMorph methodsFor: 'geometry' stamp: 'sd 11/8/2003 15:56'! extent: aPoint "change the receiver's extent" super extent: aPoint . self updateColor! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/13/2003 21:07'! createAcceptButton "create the [accept] button" | result frame | result := SimpleButtonMorph new target: self; color: Color lightGreen. result borderColor: (Preferences menuAppearance3d ifTrue: [#raised] ifFalse: [result color twiceDarker]). result label: 'Accept(s)' translated; actionSelector: #accept. result setNameTo: 'accept'. frame := LayoutFrame new. frame rightFraction: 0.5; rightOffset: -10; bottomFraction: 1.0; bottomOffset: -2. result layoutFrame: frame. self addMorph: result. self updateColor: result color: result color intensity: 2. ^ result! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/13/2003 21:07'! createCancelButton "create the [cancel] button" | result frame | result := SimpleButtonMorph new target: self; color: Color lightRed. result borderColor: (Preferences menuAppearance3d ifTrue: [#raised] ifFalse: [result color twiceDarker]). result label: 'Cancel(l)' translated; actionSelector: #cancel. result setNameTo: 'cancel'. frame := LayoutFrame new. frame leftFraction: 0.5; leftOffset: 10; bottomFraction: 1.0; bottomOffset: -2. result layoutFrame: frame. self addMorph: result. self updateColor: result color: result color intensity: 2. ^ result! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 17:52'! createQueryTextMorph: queryString "create the queryTextMorph" | result frame | result := TextMorph new contents: queryString. result setNameTo: 'query' translated. result lock. frame := LayoutFrame new. frame topFraction: 0.0; topOffset: 2. frame leftFraction: 0.5; leftOffset: (result width // 2) negated. result layoutFrame: frame. self addMorph: result. ^ result! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:56'! createTextPaneExtent: answerExtent acceptBoolean: acceptBoolean topOffset: topOffset buttonAreaHeight: buttonAreaHeight "create the textPane" | result frame | result := PluggableTextMorph on: self text: #response accept: #response: readSelection: #selectionInterval menu: #codePaneMenu:shifted:. result extent: answerExtent. result hResizing: #spaceFill; vResizing: #spaceFill. result borderWidth: 1. result hasUnacceptedEdits: true. result acceptOnCR: acceptBoolean. result setNameTo: 'textPane'. frame := LayoutFrame new. frame leftFraction: 0.0; rightFraction: 1.0; topFraction: 0.0; topOffset: topOffset; bottomFraction: 1.0; bottomOffset: buttonAreaHeight negated. result layoutFrame: frame. self addMorph: result. ^ result! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57'! initialize super initialize. self setDefaultParameters. self extent: 400 @ 150. responseUponCancel := ''. Preferences roundedMenuCorners ifTrue: [self useRoundedCorners]. ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:57'! setDefaultParameters "change the receiver's appareance parameters" | colorFromMenu worldColor menuColor menuBorderColor | colorFromMenu := Preferences menuColorFromWorld and: [Display depth > 4] and: [(worldColor := self currentWorld color) isColor]. menuColor := colorFromMenu ifTrue: [worldColor luminance > 0.7 ifTrue: [worldColor mixed: 0.85 with: Color black] ifFalse: [worldColor mixed: 0.4 with: Color white]] ifFalse: [Preferences menuColor]. menuBorderColor := Preferences menuAppearance3d ifTrue: [#raised] ifFalse: [colorFromMenu ifTrue: [worldColor muchDarker] ifFalse: [Preferences menuBorderColor]]. self setColor: menuColor borderWidth: Preferences menuBorderWidth borderColor: menuBorderColor. self layoutInset: 3! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'! setQuery: queryString initialAnswer: initialAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean | query topOffset accept cancel buttonAreaHeight | response := initialAnswer. done := false. self removeAllMorphs. self layoutPolicy: ProportionalLayout new. query := self createQueryTextMorph: queryString. topOffset := query height + 4. accept := self createAcceptButton. cancel := self createCancelButton. buttonAreaHeight := (accept height max: cancel height) + 4. textPane := self createTextPaneExtent: answerExtent acceptBoolean: acceptBoolean topOffset: topOffset buttonAreaHeight: buttonAreaHeight. self extent: (query extent x max: answerExtent x) + 4 @ (topOffset + answerExtent y + 4 + buttonAreaHeight). ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'NS 8/1/2000 11:44'! setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean self setQuery: queryString initialAnswer: initialAnswer answerExtent: (self class defaultAnswerExtent x @ answerHeight) acceptOnCR: acceptBoolean ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'! updateColor "update the recevier's fillStyle" | textPaneBorderColor | self updateColor: self color: self color intensity: 1. textPane isNil ifTrue: [^ self]. textPaneBorderColor := self borderColor == #raised ifTrue: [#inset] ifFalse: [self borderColor]. textPane borderColor: textPaneBorderColor! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sd 11/8/2003 15:58'! updateColor: aMorph color: aColor intensity: anInteger "update the apareance of aMorph" | fill fromColor toColor | Preferences gradientMenu ifFalse: [^ self]. fromColor := aColor. toColor := aColor. anInteger timesRepeat: [ fromColor := fromColor lighter. toColor := toColor darker]. fill := GradientFillStyle ramp: {0.0 -> fromColor. 1 -> toColor}. fill origin: aMorph topLeft. fill direction: aMorph width @ 0. fill radial: true. aMorph fillStyle: fill! ! !FillInTheBlankMorph methodsFor: 'invoking' stamp: 'jrp 10/4/2004 16:06'! getUserResponse "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." | w | w _ self world. w ifNil: [^ response]. (ProvideAnswerNotification signal: (self submorphOfClass: TextMorph) userString) ifNotNilDo: [:answer | self delete. w doOneCycle. ^ response _ (answer == #default) ifTrue: [response] ifFalse: [answer]]. done _ false. w activeHand newKeyboardFocus: textPane. [done] whileFalse: [w doOneCycle]. self delete. w doOneCycle. ^ response ! ! !FillInTheBlankMorph class methodsFor: 'default constants' stamp: 'dgd 4/27/2003 17:10'! defaultAnswerExtent ^ (200@60 * (Preferences standardMenuFont height / 12)) rounded! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! request: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlankMorph request: 'What is your favorite color?'" ^ self request: queryString initialAnswer: '' centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/18/2001 00:54'! request: queryString initialAnswer: defaultAnswer "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlankMorph request: 'What is your favorite color?' initialAnswer: 'red, no blue. Ahhh!!'" ^ self request: queryString initialAnswer: defaultAnswer centerAt: ActiveHand cursorPoint! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'ar 3/17/2001 23:43'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels. This variant is only for calling from within a Morphic project." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: ActiveWorld ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:44'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: self defaultAnswerExtent! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:39'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: answerExtent "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | aFillInTheBlankMorph | aFillInTheBlankMorph _ self new setQuery: queryString initialAnswer: defaultAnswer answerExtent: answerExtent acceptOnCR: acceptBoolean. aFillInTheBlankMorph responseUponCancel: returnOnCancel. aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. ^ aFillInTheBlankMorph getUserResponse ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'NS 8/1/2000 11:43'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerHeight: answerHeight "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean answerExtent: self defaultAnswerExtent x @ answerHeight! ! !FillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:41'! mixed: fraction with: aColor ^self asColor mixed: fraction with: aColor! ! !FillStyle commentStamp: '' prior: 0! FillStyle is an abstract base class for fills in the BalloonEngine.! !FishEyeMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:39'! initialize "initialize the state of the receiver" super initialize. "" "magnification should be always 1" magnification _ 1. d _ 1.3. self extent: 130 @ 130! ! !FishEyeMorph methodsFor: 'initialization' stamp: 'md 11/14/2003 16:32'! transformX: aFloatArray | focus gridNum2 subArray dMaxX | focus _ srcExtent x asFloat / 2. gridNum2 _ (aFloatArray findFirst: [:x | x > focus]) - 1. dMaxX _ 0.0 - focus. subArray _ self g: (aFloatArray copyFrom: 1 to: gridNum2) max: dMaxX focus: focus. aFloatArray replaceFrom: 1 to: gridNum2 with: subArray startingAt: 1. dMaxX _ focus. " = (size - focus)" subArray _ self g: (aFloatArray copyFrom: gridNum2 + 1 to: gridNum x + 1) max: dMaxX focus: focus. aFloatArray replaceFrom: gridNum2 + 1 to: gridNum x + 1 with: subArray startingAt: 1. ! ! !FishEyeMorph methodsFor: 'initialization' stamp: 'dgd 2/21/2003 23:04'! transformY: aFloatArray | focus subArray dMaxY | focus := srcExtent y asFloat / 2. dMaxY := (aFloatArray first) <= focus ifTrue: [0.0 - focus] ifFalse: [focus]. subArray := self g: (aFloatArray copyFrom: 1 to: gridNum x + 1) max: dMaxY focus: focus. aFloatArray replaceFrom: 1 to: gridNum x + 1 with: subArray startingAt: 1! ! !FishEyeMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! initializeToStandAlone super initializeToStandAlone. "magnification should be always 1" magnification _ 1. d _ 1.3. self extent: 130@130. ! ! !FishEyeMorph methodsFor: 'menus' stamp: 'dgd 9/21/2003 17:55'! chooseMagnification self inform: 'Magnification is fixed, sorry.' translated! ! !FishEyeMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:47'! descriptionForPartsBin ^ self partName: 'FishEye' categories: #('Useful') documentation: 'An extreme-wide-angle lens'! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! ascent ^baseFont ascent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! ascentOf: aCharacter ^ self ascent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont ^baseFont! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont: aFont baseFont := aFont! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! baseKern ^baseFont baseKern! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 02:01'! characterFormAt: character ^ baseFont characterFormAt: substitutionCharacter! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'! descent ^baseFont descent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:58'! descentKern ^baseFont descentKern! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! descentOf: aCharacter ^ self descent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:10'! emphasized: emph ^self class new baseFont: (baseFont emphasized: emph)! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:25'! familyName ^baseFont familyName, '-pw'! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:19'! fontSize: aNumber self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! height ^baseFont height! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:26'! lineGrid ^baseFont lineGrid! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! maxAscii ^ SmallInteger maxVal! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! passwordCharacter ^$*! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:28'! pointSize ^baseFont pointSize! ! !FixedFaceFont methodsFor: 'measuring' stamp: 'tak 12/20/2004 18:05'! widthOf: aCharacter ^ baseFont widthOf: substitutionCharacter! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:49'! displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta baselineY: baselineY! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 18:06'! displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:50'! displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY | maskedString | maskedString := String new: length. maskedString atAllPut: substitutionCharacter. ^ baseFont displayString: maskedString on: aCanvas from: 1 to: length at: aPoint kern: kernDelta baselineY: baselineY! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:00'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta | size | size := stopIndex - startIndex + 1. ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 12:19'! displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY | size | size := stopIndex - startIndex + 1. ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'tak 12/20/2004 11:10'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont | destPoint | destPoint := self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta. ^ Array with: stopIndex + 1 with: destPoint! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'yo 1/7/2005 11:51'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY | destPoint | destPoint := self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY. ^ Array with: stopIndex + 1 with: destPoint! ! !FixedFaceFont methodsFor: 'displaying' stamp: 'ar 1/5/2003 17:00'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! ! !FixedFaceFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:48'! releaseCachedState baseFont releaseCachedState.! ! !FixedFaceFont methodsFor: 'initialize-release' stamp: 'yo 1/7/2005 11:59'! errorFont displaySelector := #displayErrorOn:length:at:kern:baselineY:. substitutionCharacter := $?.! ! !FixedFaceFont methodsFor: 'initialize-release' stamp: 'tak 12/20/2004 10:37'! initialize baseFont := TextStyle defaultFont. self passwordFont! ! !FixedFaceFont methodsFor: 'initialize-release' stamp: 'yo 1/7/2005 11:59'! passwordFont displaySelector := #displayPasswordOn:length:at:kern:baselineY:. substitutionCharacter := $*! ! !FixedFaceFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:54'! glyphInfoOf: aCharacter into: glyphInfoArray ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. ! ! !FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0! I am a font for special purpose like password or fallback. I can show same form whenever someone requests any character. Variable displaySelector is future use to show a form dynamically. (Although it would be unnecessary...)! !FlapTab methodsFor: 'access' stamp: 'dgd 8/31/2003 18:58'! acquirePlausibleFlapID "Give the receiver a flapID that is globally unique; try to hit the mark vis a vis the standard system flap id's, for the case when this method is invoked as part of the one-time transition" | wording | wording _ self wording. (wording isEmpty or: [wording = '---']) ifTrue: [wording _ 'Flap' translated]. ^ self provideDefaultFlapIDBasedOn: wording! ! !FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'! flapID "Answer the receiver's flapID, creating it if necessary" ^ self knownName ifNil: [self acquirePlausibleFlapID]! ! !FlapTab methodsFor: 'access' stamp: 'sw 4/30/2001 18:39'! flapID: anID "Set the receiver's flapID" self setNameTo: anID! ! !FlapTab methodsFor: 'access' stamp: 'sw 5/4/2001 23:25'! flapIDOrNil "If the receiver has a flapID, answer it, else answer nil" ^ self knownName! ! !FlapTab methodsFor: 'accessing' stamp: 'tk 9/25/2002 18:08'! labelString ^labelString! ! !FlapTab methodsFor: 'e-toy support' stamp: 'sw 7/28/2001 01:31'! succeededInRevealing: aPlayer "Try to reveal aPlayer, and answer whether we succeeded" (super succeededInRevealing: aPlayer) ifTrue: [^ true]. self flapShowing ifTrue: [^ false]. (referent succeededInRevealing: aPlayer) ifTrue: [self showFlap. aPlayer costume goHome; addHalo. ^ true]. ^ false! ! !FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 20:51'! applyEdgeFractionWithin: aBoundsRectangle "Make the receiver reflect remembered edgeFraction" | newPosition | edgeFraction ifNil: [^ self]. self isCurrentlySolid ifTrue: [^ self]. newPosition _ self ifVertical: [self left @ (self edgeFraction * (aBoundsRectangle height - self height))] ifHorizontal: [(self edgeFraction * (aBoundsRectangle width - self width) @ self top)]. self position: (aBoundsRectangle origin + newPosition) ! ! !FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:01'! computeEdgeFraction "Compute and remember the edge fraction" | aBox aFraction | self isCurrentlySolid ifTrue: [^ edgeFraction ifNil: [self edgeFraction: 0.5]]. aBox _ ((owner ifNil: [ActiveWorld]) bounds) insetBy: (self extent // 2). aFraction _ self ifVertical: [(self center y - aBox top) / (aBox height max: 1)] ifHorizontal: [(self center x - aBox left) / (aBox width max: 1)]. ^ self edgeFraction: aFraction! ! !FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 06:56'! edgeFraction ^ edgeFraction ifNil: [self computeEdgeFraction]! ! !FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 08:38'! edgeFraction: aNumber "Set my edgeFraction to the given number, without side effects" edgeFraction _ aNumber asFloat! ! !FlapTab methodsFor: 'edge' stamp: 'yo 2/10/2005 18:06'! edgeString ^ 'cling to edge... (current: {1})' translated format: {edgeToAdhereTo translated}! ! !FlapTab methodsFor: 'edge' stamp: 'sw 10/31/2001 15:58'! ifVertical: block1 ifHorizontal: block2 "Evaluate and return the value of either the first or the second block, depending whether I am vertically or horizontally oriented" ^ self orientation == #vertical ifTrue: [block1 value] ifFalse: [block2 value] ! ! !FlapTab methodsFor: 'edge' stamp: 'yo 11/4/2002 20:50'! setEdge: anEdge "Set the edge as indicated, if possible" | newOrientation | self edgeToAdhereTo = anEdge ifTrue: [^ self]. newOrientation _ nil. self orientation == #vertical ifTrue: [(#(top bottom) includes: anEdge) ifTrue: [newOrientation _ #horizontal]] ifFalse: [(#(top bottom) includes: anEdge) ifFalse: [newOrientation _ #vertical]]. self edgeToAdhereTo: anEdge. newOrientation ifNotNil: [self transposeParts]. referent isInWorld ifTrue: [self positionReferent]. self changeTabText: self existingWording. self adjustPositionVisAVisFlap! ! !FlapTab methodsFor: 'edge' stamp: 'dgd 10/17/2003 22:36'! setEdgeToAdhereTo | aMenu | aMenu _ MenuMorph new defaultTarget: self. #(left top right bottom) do: [:sym | aMenu add: sym asString translated target: self selector: #setEdge: argument: sym]. aMenu popUpEvent: self currentEvent in: self world! ! !FlapTab methodsFor: 'event handling' stamp: 'sw 10/31/2001 15:46'! mouseMove: evt | aPosition newReferentThickness adjustedPosition thick | dragged ifFalse: [(thick _ self referentThickness) > 0 ifTrue: [lastReferentThickness _ thick]]. ((self containsPoint: (aPosition _ evt cursorPoint)) and: [dragged not]) ifFalse: [flapShowing ifFalse: [self showFlap]. adjustedPosition _ aPosition - evt hand targetOffset. (edgeToAdhereTo == #bottom) ifTrue: [newReferentThickness _ inboard ifTrue: [self world height - adjustedPosition y] ifFalse: [self world height - adjustedPosition y - self height]]. (edgeToAdhereTo == #left) ifTrue: [newReferentThickness _ inboard ifTrue: [adjustedPosition x + self width] ifFalse: [adjustedPosition x]]. (edgeToAdhereTo == #right) ifTrue: [newReferentThickness _ inboard ifTrue: [self world width - adjustedPosition x] ifFalse: [self world width - adjustedPosition x - self width]]. (edgeToAdhereTo == #top) ifTrue: [newReferentThickness _ inboard ifTrue: [adjustedPosition y + self height] ifFalse: [adjustedPosition y]]. self isCurrentlySolid ifFalse: [(#(left right) includes: edgeToAdhereTo) ifFalse: [self left: adjustedPosition x] ifTrue: [self top: adjustedPosition y]]. self applyThickness: newReferentThickness. dragged _ true. self fitOnScreen. self computeEdgeFraction]! ! !FlapTab methodsFor: 'event handling' stamp: 'sw 11/22/2001 08:11'! mouseUp: evt "The mouse came back up, presumably after having dragged the tab. Caution: if not operating full-screen, this notification can easily be *missed*, which is why the edge-fraction-computation is also being done on mouseMove." super mouseUp: evt. (self referentThickness <= 0 or: [(referent isInWorld and: [(referent boundsInWorld intersects: referent owner boundsInWorld) not])]) ifTrue: [self hideFlap. flapShowing _ false]. self fitOnScreen. dragged ifTrue: [self computeEdgeFraction. dragged _ false]. Flaps doAutomaticLayoutOfFlapsIfAppropriate! ! !FlapTab methodsFor: 'events' stamp: 'sw 2/12/2001 17:04'! tabSelected "The user clicked on the tab. Show or hide the flap. Try to be a little smart about a click on a tab whose flap is open but only just barely." dragged == true ifTrue: [^ dragged _ false]. self flapShowing ifTrue: [self referentThickness < 23 "an attractive number" ifTrue: [self openFully] ifFalse: [self hideFlap]] ifFalse: [self showFlap]! ! !FlapTab methodsFor: 'globalness' stamp: 'sw 5/4/2001 23:25'! isGlobalFlap "Answer whether the receiver is currently a shared flap" ^ Flaps globalFlapTabsIfAny includes: self! ! !FlapTab methodsFor: 'globalness' stamp: 'dgd 8/30/2003 21:36'! isGlobalFlapString "Answer a string to construct a menu item representing control over whether the receiver is or is not a shared flap" ^ (self isGlobalFlap ifTrue: [''] ifFalse: ['']) , 'shared by all projects' translated! ! !FlapTab methodsFor: 'globalness' stamp: 'sw 4/30/2001 18:52'! toggleIsGlobalFlap "Toggle whether the receiver is currently a global flap or not" | oldWorld | self hideFlap. oldWorld _ self currentWorld. self isGlobalFlap ifTrue: [Flaps removeFromGlobalFlapTabList: self. oldWorld addMorphFront: self] ifFalse: [self delete. Flaps addGlobalFlap: self. self currentWorld addGlobalFlaps]. ActiveWorld reformulateUpdatingMenus ! ! !FlapTab methodsFor: 'graphical tabs' stamp: 'dgd 8/30/2003 21:29'! graphicalTabString ^ (self isCurrentlyGraphical ifTrue: ['choose new graphic...'] ifFalse: ['use graphical tab']) translated! ! !FlapTab methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'! initialize "initialize the state of the receiver" super initialize. "" edgeToAdhereTo _ #left. flapShowing _ false. slidesOtherObjects _ false. popOutOnDragOver _ false. popOutOnMouseOver _ false. inboard _ false. dragged _ false! ! !FlapTab methodsFor: 'initialization' stamp: 'di 11/18/2001 13:09'! provideDefaultFlapIDBasedOn: aStem "Provide the receiver with a default flap id" | aNumber usedIDs anID | aNumber _ 0. usedIDs _ FlapTab allSubInstances select: [:f | f ~~ self] thenCollect: [:f | f flapIDOrNil]. anID _ aStem. [usedIDs includes: anID] whileTrue: [aNumber _ aNumber + 1. anID _ aStem, (aNumber asString)]. self flapID: anID. ^ anID! ! !FlapTab methodsFor: 'initialization' stamp: 'di 11/19/2001 21:20'! setName: nameString edge: edgeSymbol color: flapColor "Set me up with the usual..." self setNameTo: nameString. self edgeToAdhereTo: edgeSymbol; inboard: false. self assumeString: nameString font: Preferences standardFlapFont orientation: self orientation color: flapColor. self setToPopOutOnDragOver: true. self setToPopOutOnMouseOver: false. ! ! !FlapTab methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:21'! addCustomMenuItems: aMenu hand: aHandMorph "Add further items to the menu as appropriate" aMenu add: 'tab color...' translated target: self action: #changeColor. aMenu add: 'flap color...' translated target: self action: #changeFlapColor. aMenu addLine. aMenu addUpdating: #edgeString action: #setEdgeToAdhereTo. aMenu addLine. aMenu addUpdating: #textualTabString action: #textualTab. aMenu addUpdating: #graphicalTabString action: #graphicalTab. aMenu addUpdating: #solidTabString enablement: #notSolid action: #solidTab. aMenu addLine. (referent isKindOf: PasteUpMorph) ifTrue: [aMenu addUpdating: #partsBinString action: #togglePartsBinMode]. aMenu addUpdating: #dragoverString action: #toggleDragOverBehavior. aMenu addUpdating: #mouseoverString action: #toggleMouseOverBehavior. aMenu addLine. aMenu addUpdating: #isGlobalFlapString enablement: #sharedFlapsAllowed action: #toggleIsGlobalFlap. aMenu balloonTextForLastItem: 'If checked, this flap will be available in all morphic projects; if not, it will be private to this project.,' translated. aMenu addLine. aMenu add: 'destroy this flap' translated action: #destroyFlap. "aMenu addUpdating: #slideString action: #toggleSlideBehavior. aMenu addUpdating: #inboardString action: #toggleInboardness. aMenu addUpdating: #thicknessString ('thickness... (current: ', self thickness printString, ')') action: #setThickness." ! ! !FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'! changeColor self isCurrentlyGraphical ifTrue: [^ self inform: 'Color only pertains to a flap tab when the tab is textual or "solid". This tab is currently graphical, so color-choice does not apply.' translated]. super changeColor ! ! !FlapTab methodsFor: 'menu' stamp: 'dgd 9/21/2003 17:55'! changeFlapColor (self flapShowing) ifTrue: [referent changeColor] ifFalse: [self inform: 'The flap itself needs to be open before you can change its color.' translated]! ! !FlapTab methodsFor: 'menu' stamp: 'yo 7/2/2004 17:58'! changeTabText "Allow the user to change the text on the tab" | reply | reply _ FillInTheBlank request: 'new wording for this tab:' translated initialAnswer: self existingWording. reply isEmptyOrNil ifTrue: [^ self]. self changeTabText: reply. ! ! !FlapTab methodsFor: 'menu' stamp: 'dgd 9/5/2003 18:25'! destroyFlap "Destroy the receiver" | reply request | request _ self isGlobalFlap ifTrue: ['Caution -- this would permanently remove this flap, so it would no longer be available in this or any other project. Do you really want to this? '] ifFalse: ['Caution -- this is permanent!! Do you really want to do this? ']. reply _ self confirm: request translated orCancel: [^ self]. reply ifTrue: [self isGlobalFlap ifTrue: [Flaps removeFlapTab: self keepInList: false. self currentWorld reformulateUpdatingMenus] ifFalse: [referent isInWorld ifTrue: [referent delete]. self delete]]! ! !FlapTab methodsFor: 'menu' stamp: 'di 11/17/2001 20:17'! existingWording ^ labelString! ! !FlapTab methodsFor: 'menu' stamp: 'gm 2/22/2003 13:11'! isCurrentlyTextual | first | ^submorphs notEmpty and: [((first := submorphs first) isKindOf: StringMorph) or: [first isTextMorph]]! ! !FlapTab methodsFor: 'menu' stamp: 'sw 4/24/2001 11:04'! sharedFlapsAllowed "Answer (for the benefit of a menu item for which I am the target) whether the system presently allows shared flaps" ^ Flaps sharedFlapsAllowed! ! !FlapTab methodsFor: 'menus' stamp: 'nk 2/15/2004 08:19'! addGestureMenuItems: aMenu hand: aHandMorph "If the receiver wishes the Genie menu items, add a line to the menu and then those Genie items, else do nothing"! ! !FlapTab methodsFor: 'misc' stamp: 'di 11/19/2001 12:19'! fitContents self isCurrentlyTextual ifFalse: [^ super fitContents]. self ifVertical: [self extent: submorphs first extent + (2 * self borderWidth) + (0@4). submorphs first position: self position + self borderWidth + (1@4)] ifHorizontal: [self extent: submorphs first extent + (2 * self borderWidth) + (8@-1). submorphs first position: self position + self borderWidth + (5@1)]! ! !FlapTab methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 18:43'! balloonTextForFlapsMenu "Answer the balloon text to show on a menu item in the flaps menu that governs the visibility of the receiver in the current project" | id | id _ self flapID. #( ('Squeak' 'Has a few generally-useful controls; it is also a place where you can "park" objects') ('Tools' 'A quick way to get browsers, change sorters, file lists, etc.') ('Widgets' 'A variety of controls and media tools') ('Supplies' 'A source for many basic types of objects') ('Stack Tools' 'Tools for building stacks. Caution!! Powerful but young and underdocumented') ('Scripting' 'Tools useful when doing tile scripting') ('Navigator' 'Project navigator: includes controls for navigating through linked projects. Also supports finding, loading and publishing projects in a shared environment') ('Painting' 'A flap housing the paint palette. Click on the closed tab to make make a new painting')) do: [:pair | (FlapTab givenID: id matches: pair first translated) ifTrue: [^ pair second translated]]. ^ self balloonText! ! !FlapTab methodsFor: 'mouseover & dragover' stamp: 'sw 7/31/2002 00:53'! arrangeToPopOutOnMouseOver: aBoolean aBoolean ifTrue: [self on: #mouseEnter send: #showFlap to: self. referent on: #mouseLeave send: #hideFlapUnlessBearingHalo to: self. self on: #mouseLeave send: #maybeHideFlapOnMouseLeave to: self] ifFalse: [self on: #mouseEnter send: nil to: nil. self on: #mouseLeave send: nil to: nil. referent on: #mouseLeave send: nil to: nil]! ! !FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:32'! dragoverString "Answer the string to be shown in a menu to represent the dragover status" ^ (popOutOnDragOver ifTrue: [''] ifFalse: ['']), 'pop out on dragover' translated! ! !FlapTab methodsFor: 'mouseover & dragover' stamp: 'ar 12/18/2000 01:14'! makeNewDrawing: evt self flapShowing ifTrue:[ self world makeNewDrawing: evt. ] ifFalse:[ self world assureNotPaintingEvent: evt. ].! ! !FlapTab methodsFor: 'mouseover & dragover' stamp: 'dgd 8/30/2003 21:36'! mouseoverString "Answer the string to be shown in a menu to represent the mouseover status" ^ (popOutOnMouseOver ifTrue: [''] ifFalse: ['']) , 'pop out on mouseover' translated ! ! !FlapTab methodsFor: 'mouseover & dragover' stamp: 'ar 2/8/2001 19:27'! startOrFinishDrawing: evt | w | self flapShowing ifTrue:[ (w _ self world) makeNewDrawing: evt at: w center. ] ifFalse:[ self world endDrawing: evt. ].! ! !FlapTab methodsFor: 'objects from disk' stamp: 'sw 5/4/2001 23:27'! objectForDataStream: refStrm "I am about to be written on an object file. If I am a global flap, write a proxy instead." | dp | self isGlobalFlap ifTrue: [dp _ DiskProxy global: #Flaps selector: #globalFlapTabOrDummy: args: {self flapID}. refStrm replace: self with: dp. ^ dp]. ^ super objectForDataStream: refStrm! ! !FlapTab methodsFor: 'parts bin' stamp: 'dgd 8/30/2003 21:31'! partsBinString "Answer the string to be shown in a menu to represent the parts-bin status" ^ (referent isPartsBin ifTrue: [''] ifFalse: ['']), 'parts-bin' translated! ! !FlapTab methodsFor: 'positioning' stamp: 'di 11/21/2001 16:02'! transposeParts "The receiver's orientation has just been changed from vertical to horizontal or vice-versa." "First expand the flap to screen size, letting the submorphs lay out to fit, and then shrink the minor dimension back to the last row." self isCurrentlyTextual ifTrue: "First recreate the tab with proper orientation" [self assumeString: self existingWording font: Preferences standardFlapFont orientation: self orientation color: self color]. self orientation == #vertical ifTrue: "changed from horizontal" [referent listDirection: #topToBottom; wrapDirection: #leftToRight. referent hasSubmorphs ifTrue: [referent extent: self currentWorld extent. referent fullBounds. "Needed to trigger layout" referent width: (referent submorphs collect: [:m | m right]) max - referent left + self width]] ifFalse: [referent listDirection: #leftToRight; wrapDirection: #topToBottom. referent hasSubmorphs ifTrue: [referent extent: self currentWorld extent. referent fullBounds. "Needed to trigger layout" referent height: (referent submorphs collect: [:m | m bottom]) max - referent top + self height]]. referent hasSubmorphs ifFalse: [referent extent: 100@100]. self spanWorld. flapShowing ifTrue: [self showFlap]! ! !FlapTab methodsFor: 'rounding' stamp: 'di 11/20/2001 08:20'! roundedCorners edgeToAdhereTo == #bottom ifTrue: [^ #(1 4)]. edgeToAdhereTo == #right ifTrue: [^ #(1 2)]. edgeToAdhereTo == #left ifTrue: [^ #(3 4)]. ^ #(2 3) "#top and undefined" ! ! !FlapTab methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'! wantsRoundedCorners ^self isCurrentlyTextual or:[super wantsRoundedCorners]! ! !FlapTab methodsFor: 'show & hide' stamp: 'sw 11/24/2001 21:50'! hideFlapUnlessOverReferent "Hide the flap unless the mouse is over my referent." | aWorld where | (referent isInWorld and: [where _ self outermostWorldMorph activeHand lastEvent cursorPoint. referent bounds containsPoint: (referent globalPointToLocal: where)]) ifTrue: [^ self]. (aWorld _ self world) ifNil: [^ self]. "In case flap tabs just got hidden" self referent delete. aWorld removeAccommodationForFlap: self. flapShowing _ false. self isInWorld ifFalse: [self inboard ifTrue: [aWorld addMorphFront: self]]. self adjustPositionAfterHidingFlap! ! !FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:49'! lastReferentThickness: anInteger "Set the last remembered referent thickness to the given integer" lastReferentThickness _ anInteger! ! !FlapTab methodsFor: 'show & hide' stamp: 'sw 2/12/2001 16:59'! openFully "Make an educated guess at how wide or tall we are to be, and open to that thickness" | thickness amt | thickness _ referent boundingBoxOfSubmorphs extent max: (100 @ 100). self applyThickness: (amt _ self orientation == #horizontal ifTrue: [thickness y] ifFalse: [thickness x]). self lastReferentThickness: amt. self showFlap! ! !FlapTab methodsFor: 'show & hide' stamp: 'dgd 8/31/2004 16:25'! showFlap "Open the flap up" | thicknessToUse flapOwner | "19 sept 2000 - going for all paste ups <- raa note" flapOwner _ self pasteUpMorph. self referentThickness <= 0 ifTrue: [thicknessToUse _ lastReferentThickness ifNil: [100]. self orientation == #horizontal ifTrue: [referent height: thicknessToUse] ifFalse: [referent width: thicknessToUse]]. inboard ifTrue: [self stickOntoReferent]. "makes referent my owner, and positions me accordingly" referent pasteUpMorph == flapOwner ifFalse: [flapOwner accommodateFlap: self. "Make room if needed" flapOwner addMorphFront: referent. flapOwner startSteppingSubmorphsOf: referent. self positionReferent. referent adaptToWorld: flapOwner]. inboard ifFalse: [self adjustPositionVisAVisFlap]. flapShowing _ true. self pasteUpMorph hideFlapsOtherThan: self ifClingingTo: edgeToAdhereTo. flapOwner bringTopmostsToFront! ! !FlapTab methodsFor: 'solid tabs' stamp: 'dgd 2/21/2003 22:39'! changeTabThickness | newThickness | newThickness := FillInTheBlank request: 'New thickness:' initialAnswer: self tabThickness printString. newThickness notEmpty ifTrue: [self applyTabThickness: newThickness]! ! !FlapTab methodsFor: 'solid tabs' stamp: 'dgd 8/30/2003 21:31'! solidTabString ^ (self isCurrentlySolid ifTrue: ['currently using solid tab'] ifFalse: ['use solid tab']) translated! ! !FlapTab methodsFor: 'submorphs-add/remove' stamp: 'sw 11/27/2001 12:13'! dismissViaHalo "Dismiss the receiver (and its referent), unless it resists" self resistsRemoval ifTrue: [(PopUpMenu confirm: 'Really throw this flap away' trueChoice: 'Yes' falseChoice: 'Um, no, let me reconsider') ifFalse: [^ self]]. referent delete. self delete! ! !FlapTab methodsFor: 'textual tabs' stamp: 'yo 7/16/2003 15:25'! assumeString: aString font: aFont orientation: orientationSymbol color: aColor | aTextMorph workString tabStyle | labelString := aString asString. workString := orientationSymbol == #vertical ifTrue: [String streamContents: [:s | labelString do: [:c | s nextPut: c] separatedBy: [s nextPut: Character cr]]] ifFalse: [labelString]. tabStyle := (TextStyle new) leading: 0; newFontArray: (Array with: aFont). aTextMorph := (TextMorph new setTextStyle: tabStyle) contents: (workString asText addAttribute: (TextKern kern: 3)). self removeAllMorphs. self borderWidth: 2; borderColor: #raised. aColor ifNotNil: [self color: aColor]. self addMorph: aTextMorph centered. aTextMorph lock " FlapTab allSubInstancesDo: [:ft | ft reformatTextualTab] "! ! !FlapTab methodsFor: 'textual tabs' stamp: 'ar 9/3/2004 14:58'! changeTabText: aString | label | aString isEmptyOrNil ifTrue: [^ self]. label _ Locale current languageEnvironment class flapTabTextFor: aString in: self. label isEmptyOrNil ifTrue: [^ self]. self useStringTab: label. submorphs first delete. self assumeString: label font: Preferences standardFlapFont orientation: (Flaps orientationForEdge: self edgeToAdhereTo) color: nil. ! ! !FlapTab methodsFor: 'textual tabs' stamp: 'dgd 8/30/2003 21:27'! textualTabString ^ (self isCurrentlyTextual ifTrue: ['change tab wording...'] ifFalse: ['use textual tab']) translated! ! !FlapTab methodsFor: 'textual tabs' stamp: 'di 11/17/2001 20:22'! useStringTab: aString | aLabel | labelString _ aString asString. aLabel _ StringMorph new contents: labelString. self addMorph: aLabel. aLabel position: self position. aLabel highlightColor: self highlightColor; regularColor: self regularColor. aLabel lock. self fitContents. self layoutChanged! ! !FlapTab methodsFor: 'textual tabs' stamp: 'dgd 10/8/2003 19:03'! useTextualTab | stringToUse colorToUse | self preserveDetails. colorToUse _ self valueOfProperty: #priorColor ifAbsent: [Color green muchLighter]. submorphs notEmpty ifTrue: [self removeAllMorphs]. stringToUse _ self valueOfProperty: #priorWording ifAbsent: ['Unnamed Flap' translated]. self assumeString: stringToUse font: Preferences standardFlapFont orientation: self orientation color: colorToUse! ! !FlapTab class methodsFor: 'as yet unclassified' stamp: 'di 11/19/2001 21:59'! givenID: aFlapID matches: pureID "eg, FlapTab givenID: 'Stack Tools2' matches: 'Stack Tools' " ^ aFlapID = pureID or: [(aFlapID beginsWith: pureID) and: [(aFlapID copyFrom: pureID size+1 to: aFlapID size) allSatisfy: [:c | c isDigit]]]! ! !Flaps commentStamp: 'asm 3/13/2003 12:46' prior: 0! ClassVariables FlapsQuads quads defining predefined flaps default flaps are: 'PlugIn Supplies', 'Stack Tools', 'Supplies', 'Tools', 'Widgets' and 'Scripting' SharedFlapTabs an array of flaps shared between squeak projects SharedFlapsAllowed boolean ! !Flaps class methodsFor: 'construction support' stamp: 'sw 5/4/2001 23:52'! addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: flapBlock "If any global flap satisfies flapBlock, add aMorph to it at the given position. Applies to flaps that are parts bins and that like thumbnailing" | aFlapTab flapPasteUp | aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. flapPasteUp _ aFlapTab referent. flapPasteUp addMorph: aMorph asElementNumber: aNumber. flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true! ! !Flaps class methodsFor: 'construction support' stamp: 'sw 5/4/2001 23:52'! addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: anID "If any global flap satisfies flapBlock, add aMorph to it at the given position. No senders in the image -- intended to be invoked by doits in code updates only, and applies to flaps that are parts bins and that like thumbnailing" ^ self addMorph: aMorph asElementNumber: aNumber inGlobalFlapSatisfying: [:aFlap | aFlap flapID = anID]! ! !Flaps class methodsFor: 'construction support' stamp: 'sw 4/30/2001 18:57'! addToSuppliesFlap: aMorph asElementNumber: aNumber "Add the given morph to the supplies flap. To be called by doits in updates, so don't be alarmed by its lack of senders." self addMorph: aMorph asElementNumber: aNumber inGlobalFlapWithID: 'Supplies'! ! !Flaps class methodsFor: 'construction support' stamp: 'sw 5/5/2001 02:12'! deleteMorphsSatisfying: deleteBlock fromGlobalFlapSatisfying: flapBlock "If any global flap satisfies flapBlock, then delete objects satisfying from deleteBlock from it. Occasionally called from do-its in updates or other fileouts." | aFlapTab flapPasteUp | aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. flapPasteUp _ aFlapTab referent. flapPasteUp submorphs do: [:aMorph | (deleteBlock value: aMorph) ifTrue: [aMorph delete]]! ! !Flaps class methodsFor: 'construction support' stamp: 'sw 7/5/2004 17:54'! possiblyReplaceEToyFlaps "If in eToyFriendly mode, and if it's ok to reinitialize flaps, replace the existing flaps with up-too-date etoy flaps. Caution: this is destructive of existing flaps. If preserving the contents of existing flaps is important, set the preference 'okToReinitializeFlaps' to true" PartsBin thumbnailForPartsDescription: StickyPadMorph descriptionForPartsBin. "Puts StickyPadMorph's custom icon back in the cache which typically will have been called" (Preferences eToyFriendly and: [Preferences okToReinitializeFlaps]) ifTrue: [Flaps disableGlobalFlaps: false. Flaps addAndEnableEToyFlaps. Smalltalk isMorphic ifTrue: [ActiveWorld enableGlobalFlaps]]. "PartsBin clearThumbnailCache" "Flaps possiblyReplaceEToyFlaps"! ! !Flaps class methodsFor: 'flap mechanics' stamp: 'sw 2/16/1999 18:29'! clobberFlapTabList "Flaps clobberFlapTabList" SharedFlapTabs _ nil! ! !Flaps class methodsFor: 'flap mechanics' stamp: 'sw 7/12/2001 22:01'! freshFlapsStart "To be called manually only, as a drastic measure. Delete all flap artifacts and establish fresh default global flaps Flaps freshFlapsStart " self currentWorld deleteAllFlapArtifacts. self clobberFlapTabList. self addStandardFlaps ! ! !Flaps class methodsFor: 'flap mechanics' stamp: 'dgd 10/7/2003 22:47'! reinstateDefaultFlaps "Remove all existing 'standard' global flaps clear the global list, and and add fresh ones. To be called by doits in updates etc. This is a radical step, but it does *not* clobber non-standard global flaps or local flaps. To get the effect of the *former* version of this method, call Flaps freshFlapsStart" "Flaps reinstateDefaultFlaps" self globalFlapTabsIfAny do: [:aFlapTab | ({ 'Painting' translated. 'Stack Tools' translated. 'Squeak' translated. 'Menu' translated. 'Widgets' translated. 'Tools' translated. 'Supplies' translated. 'Scripting' translated. 'Objects' translated. 'Navigator' translated } includes: aFlapTab flapID) ifTrue: [self removeFlapTab: aFlapTab keepInList: false]]. "The following reduces the risk that flaps will be created with variant IDs such as 'Stack Tools2', potentially causing some shared flap logic to fail." "Smalltalk garbageCollect." "-- see if we are OK without this" self addStandardFlaps. "self disableGlobalFlapWithID: 'Scripting'. self disableGlobalFlapWithID: 'Objects'." self currentWorld addGlobalFlaps. self currentWorld reformulateUpdatingMenus. ! ! !Flaps class methodsFor: 'flap mechanics' stamp: 'sw 4/17/2001 14:47'! removeFlapTab: aFlapTab keepInList: aBoolean "Remove the given flap tab from the screen, and, if aBoolean is true, also from the global list" (SharedFlapTabs ~~ nil and: [SharedFlapTabs includes: aFlapTab]) ifTrue: [aBoolean ifFalse: [self removeFromGlobalFlapTabList: aFlapTab]]. aFlapTab ifNotNil: [aFlapTab referent delete. aFlapTab delete]! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:22'! defaultsQuadsDefiningScriptingFlap "Answer a structure defining the default items in the Scripting flap. previously in quadsDeiningScriptingFlap" ^ #( (TrashCanMorph new 'Trash' 'A tool for discarding objects') (ScriptingSystem scriptControlButtons 'Status' 'Buttons to run, stop, or single-step scripts') (AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you control all the running scripts in your world') (ScriptingSystem newScriptingSpace 'Scripting' 'A confined place for drawing and scripting, with its own private stop/step/go buttons.') (PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') (ScriptableButton authoringPrototype 'Button' 'A Scriptable button') (ScriptingSystem prototypicalHolder 'Holder' 'A place for storing alternative pictures in an animation, etc.') (RandomNumberTile new 'Random' 'A tile that will produce a random number in a given range') (ScriptingSystem anyButtonPressedTiles 'ButtonDown?' 'Tiles for querying whether the mouse button is down') (ScriptingSystem noButtonPressedTiles 'ButtonUp?' 'Tiles for querying whether the mouse button is up') (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') (TextFieldMorph exampleBackgroundField 'Scrolling Field' 'A scrolling data field which will have a different value on every card of the background') (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') (StackMorph authoringPrototype 'Stack' 'A multi-card data base' ) (TextMorph exampleBackgroundLabel 'Background Label' 'A piece of text that will occur on every card of the background') (TextMorph exampleBackgroundField 'Background Field' 'A data field which will have a different value on every card of the background') ) asOrderedCollection! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:22'! defaultsQuadsDefiningStackToolsFlap "Answer a structure defining the items on the default system Stack Tools flap. previously in quadsDefiningStackToolsFlap" ^ #( (StackMorph authoringPrototype 'Stack' 'A multi-card data base' ) (StackMorph stackHelpWindow 'Stack Help' 'Some hints about how to use Stacks') (TextMorph authoringPrototype 'Simple Text' 'Text that you can edit into anything you wish') (TextMorph fancyPrototype 'Fancy Text' 'A text field with a rounded shadowed border, with a fancy font.') (ScrollableField newStandAlone 'Scrolling Text' 'Holds any amount of text; has a scroll bar') (ScriptableButton authoringPrototype 'Scriptable Button' 'A button whose script will be a method of the background Player') (StackMorph previousCardButton 'Previous Card' 'A button that takes the user to the previous card in the stack') (StackMorph nextCardButton 'Next Card' 'A button that takes the user to the next card in the stack')) asOrderedCollection ! ! !Flaps class methodsFor: 'flaps registry' stamp: 'nk 9/2/2004 15:49'! defaultsQuadsDefiningSuppliesFlap "Answer a list of quads which define the objects to appear in the default Supplies flap. previously in quadsDefiningSuppliesFlap" ^ #( (RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') (RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') (EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') (StarMorph authoringPrototype 'Star' 'A star') (CurveMorph authoringPrototype 'Curve' 'A curve') (PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') (TextMorph boldAuthoringPrototype 'Text' 'Text that you can edit into anything you desire.') (ScriptingSystem prototypicalHolder 'Holder' 'A place for storing alternative pictures in an animation, etc.') (ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') (ScriptableButton authoringPrototype 'Button' 'A Scriptable button') (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') (BookMorph authoringPrototype 'Book' 'A multi-paged structure') (TabbedPalette authoringPrototype 'TabbedPalette' 'A structure with tabs') (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') (ClockMorph authoringPrototype 'Clock' 'A simple digital clock') (BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') (BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') ) asOrderedCollection! ! !Flaps class methodsFor: 'flaps registry' stamp: 'nk 6/14/2004 08:39'! defaultsQuadsDefiningToolsFlap "Answer a structure defining the default Tools flap. previously in quadsDefiningToolsFlap" ^ OrderedCollection new addAll: #( (Browser prototypicalToolWindow 'Browser' 'A Browser is a tool that allows you to view all the code of all the classes in the system') (TranscriptStream openMorphicTranscript 'Transcript' 'A Transcript is a window usable for logging and debugging; browse references to #Transcript for examples of how to write to it.') (Workspace prototypicalToolWindow 'Workspace' 'A Workspace is a simple window for editing text. You can later save the contents to a file if you desire.')); add: { Preferences useFileList2 ifTrue: [ #FileList2 ] ifFalse: [ #FileList ]. #prototypicalToolWindow. 'File List'. 'A File List is a tool for browsing folders and files on disks and FTP servers.' }; addAll: #( (DualChangeSorter prototypicalToolWindow 'Change Sorter' 'Shows two change sets side by side') (SelectorBrowser prototypicalToolWindow 'Method Finder' 'A tool for discovering methods by providing sample values for arguments and results') (MessageNames prototypicalToolWindow 'Message Names' 'A tool for finding, viewing, and editing all methods whose names contain a given character sequence.') (Preferences preferencesControlPanel 'Preferences' 'Allows you to control numerous options') (Utilities recentSubmissionsWindow 'Recent' 'A message browser that tracks the most recently-submitted methods') (ProcessBrowser prototypicalToolWindow 'Processes' 'A Process Browser shows you all the running processes') (Preferences annotationEditingWindow 'Annotations' 'Allows you to specify the annotations to be shown in the annotation panes of browsers, etc.') (Scamper newOpenableMorph 'Scamper' 'A web browser') (Celeste newOpenableMorph 'Celeste' 'Celeste -- an EMail reader') (PackagePaneBrowser prototypicalToolWindow 'Packages' 'Package Browser: like a System Browser, except that if has extra level of categorization in the top-left pane, such that class-categories are further organized into groups called "packages"') (ChangeSorter prototypicalToolWindow 'Change Set' 'A tool that allows you to view and manipulate all the code changes in a single change set')); yourself! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:21'! defaultsQuadsDefiningWidgetsFlap "Answer a structure defining the default Widgets flap. previously in quadsDefiningWidgetsFlap" ^ #( (TrashCanMorph new 'Trash' 'A tool for discarding objects') (AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you see and control all the running scripts in your project') (PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') (GeeMailMorph new 'Gee-Mail' 'A place to present annotated content') (RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') (MPEGMoviePlayerMorph authoringPrototype 'Movie Player' 'A Player for MPEG movies') (FrameRateMorph authoringPrototype 'Frame Rate' 'An indicator of how fast your system is running') (MagnifierMorph newRound 'Magnifier' 'A magnifying glass') (ScriptingSystem newScriptingSpace 'Scripting' 'A confined place for drawing and scripting, with its own private stop/step/go buttons.') (ScriptingSystem holderWithAlphabet 'Alphabet' 'A source for single-letter objects') (BouncingAtomsMorph new 'Bouncing Atoms' 'Atoms, mate') (ObjectsTool newStandAlone 'Object Catalog' 'A tool that lets you browse the catalog of objects') ) asOrderedCollection! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:58'! initializeFlapsQuads "initialize the list of dynamic flaps quads. self initializeFlapsQuads" FlapsQuads _ nil. self registeredFlapsQuads at: 'PlugIn Supplies' put: self defaultsQuadsDefiningPlugInSuppliesFlap; at: 'Stack Tools' put: self defaultsQuadsDefiningStackToolsFlap; at: 'Supplies' put: self defaultsQuadsDefiningSuppliesFlap; at: 'Tools' put: self defaultsQuadsDefiningToolsFlap; at: 'Widgets' put: self defaultsQuadsDefiningWidgetsFlap; at: 'Scripting' put: self defaultsQuadsDefiningScriptingFlap. ^ self registeredFlapsQuads! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 11:09'! registerQuad: aQuad forFlapNamed: aLabel "If any previous registration of the same label string is already known, delete the old one." "aQuad received must be an array of the form {TargetObject. #command label 'A Help String'} Flaps registerQuad: #(FileList2 openMorphicViewInWorld 'Enhanced File List' 'A nicer File List.') forFlapNamed: 'Tools' " self unregisterQuad: aQuad forFlapNamed: aLabel. (self registeredFlapsQuads at: aLabel) add: aQuad! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 09:55'! registeredFlapsQuads "Answer the list of dynamic flaps quads" FlapsQuads ifNil: [FlapsQuads _ Dictionary new]. ^ FlapsQuads " FlapsQuads _ nil. "! ! !Flaps class methodsFor: 'flaps registry' stamp: 'hpt 4/26/2004 16:46'! registeredFlapsQuadsAt: aLabel "Answer the list of dynamic flaps quads at aLabel" ^ (self registeredFlapsQuads at: aLabel) removeAllSuchThat: [:q | (self environment includesKey: q first) not or: [(self environment at: q first) isNil]] ! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 3/13/2003 10:34'! unregisterQuad: aQuad forFlapNamed: aLabel "If any previous registration at the same label string has the same receiver-command, delete the old one." (self registeredFlapsQuadsAt: aLabel) removeAllSuchThat: [:q | q first = aQuad first and: [q second = aQuad second]]! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 4/12/2003 14:36'! unregisterQuadsWithReceiver: aReceiver "delete all quads with receiver aReceiver." self registeredFlapsQuads do: [:assoc | assoc value removeAllSuchThat: [:q | (self environment at: (q first)) = aReceiver ]]! ! !Flaps class methodsFor: 'flaps registry' stamp: 'asm 4/12/2003 14:16'! unregisterQuadsWithReceiver: aReceiver fromFlapNamed: aLabel "delete all quads with receiver aReceiver." (self registeredFlapsQuads at: aLabel) removeAllSuchThat: [:q | q first = aReceiver name]! ! !Flaps class methodsFor: 'menu commands' stamp: 'sw 5/7/2001 13:15'! disableGlobalFlapWithID: aFlapID "Mark this project as having the given flapID disabled" | disabledFlapIDs aFlapTab currentProject | (currentProject _ Project current) assureFlapIntegrity. Smalltalk isMorphic ifFalse: [^ self]. disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs. (aFlapTab _ self globalFlapTabWithID: aFlapID) ifNotNil: [aFlapTab hideFlap]. (disabledFlapIDs includes: aFlapID) ifFalse: [disabledFlapIDs add: aFlapID]. aFlapTab ifNotNil: [aFlapTab delete] ! ! !Flaps class methodsFor: 'menu commands' stamp: 'mir 8/22/2001 18:55'! disableGlobalFlaps "Clobber all the shared flaps structures. First read the user her Miranda rights." self disableGlobalFlaps: true! ! !Flaps class methodsFor: 'menu commands' stamp: 'dgd 8/31/2003 19:01'! disableGlobalFlaps: interactive "Clobber all the shared flaps structures. First read the user her Miranda rights." interactive ifTrue: [(self confirm: 'CAUTION!! This will destroy all the shared flaps, so that they will not be present in *any* project. If, later, you want them back, you will have to reenable them, from this same menu, whereupon the standard default set of shared flaps will be created. Do you really want to go ahead and clobber all shared flaps at this time?' translated) ifFalse: [^ self]]. self globalFlapTabsIfAny do: [:aFlapTab | self removeFlapTab: aFlapTab keepInList: false. aFlapTab isInWorld ifTrue: [self error: 'Flap problem' translated]]. self clobberFlapTabList. SharedFlapsAllowed _ false. Smalltalk isMorphic ifTrue: [ActiveWorld restoreMorphicDisplay. ActiveWorld reformulateUpdatingMenus]. "The following reduces the risk that flaps will be created with variant IDs such as 'Stack Tools2', potentially causing some shared flap logic to fail." "Smalltalk garbageCollect." "-- see if we are OK without this" ! ! !Flaps class methodsFor: 'menu commands' stamp: 'sw 11/22/2001 08:31'! enableDisableGlobalFlapWithID: aFlapID "Toggle the enable/disable status of the given global flap" | disabledFlapIDs aFlapTab currentProject | (currentProject _ Project current) assureFlapIntegrity. Smalltalk isMorphic ifFalse: [^ self]. disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs. (aFlapTab _ self globalFlapTabWithID: aFlapID) ifNotNil: [aFlapTab hideFlap]. (disabledFlapIDs includes: aFlapID) ifTrue: [disabledFlapIDs remove: aFlapID. self currentWorld addGlobalFlaps] ifFalse: [disabledFlapIDs add: aFlapID. aFlapTab ifNotNil: [aFlapTab delete]]. self doAutomaticLayoutOfFlapsIfAppropriate! ! !Flaps class methodsFor: 'menu commands' stamp: 'sw 5/7/2001 13:15'! enableGlobalFlapWithID: aFlapID "Remove any memory of this flap being disabled in this project" | disabledFlapIDs currentProject | (currentProject _ Project current) assureFlapIntegrity. Smalltalk isMorphic ifFalse: [^ self]. disabledFlapIDs _ currentProject parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ self]. disabledFlapIDs remove: aFlapID ifAbsent: [] ! ! !Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:49'! explainFlaps "Open a window giving flap help." (StringHolder new contents: self explainFlapsText translated) openLabel: 'Flaps' translated "Flaps explainFlaps" ! ! !Flaps class methodsFor: 'menu commands' stamp: 'sw 3/3/2004 15:51'! explainFlapsText "Answer the text, in English, to show in a help-window about Flaps." ^'Flaps are like drawers on the edge of the screen, which can be opened so that you can use what is inside them, and closed when you do not need them. They have many possible uses, a few of which are illustrated by the default set of flaps you can get as described below. ''Shared flaps'' are available in every morphic project. As you move from project to project, you will see these same shared flaps in each, though there are also options, on a project-by-project basis, to choose which of the shared flaps should be shown, and also momentarily to suppress the showing of all shared flaps. To get started using flaps, bring up the desktop menu and choose ''flaps...'', and make the menu stay up by choosing ''keep this menu up''. If you see, in this flaps menu, a list of flap names such as ''Squeak'', ''Tools'', etc., it means that shared flaps are already set up in your image. If you do not see the list, you will instead see a menu item that invites you to ''install default shared flaps''; choose that, and new flaps will be created, and the flaps menu will change to reflect their presence. ''Project flaps'' are flaps that belong to a single morphic project. You will see them when you are in that project, but not when you are in any other morphic project. If a flap is set up as a parts bin (such as the default Tools and Supplies flaps), you can use it to create new objects -- just open the flap, then find the object you want, and drag it out; when the cursor leaves the flap, the flap itself will snap closed, and you''ll be left holding the new object -- just click to place it exactly where you want it. If a flap is *not* set up as a parts bin (such as the default ''Squeak'' flap at the left edge of the screen) you can park objects there (this is an easy way to move objects from project to project) and you can place your own private controls there, etc. Everything in the default ''Squeak'' flap (and all the other default flaps, for that matter) is there only for illustrative purposes -- every user will want to fine-tune the flaps to suit his/her own style and needs. Each flap may be set up to appear on mouseover, dragover, both, or neither. See the menu items described below for more about these and other options. You can open a closed flap by clicking on its tab, or by dragging the tab toward the center of the screen You can close an open flap by clicking on its tab or by dragging the tab back off the edge of the screen. Drag the tab of a flap to reposition the tab and to resize the flap itself. Repositioning starts when you drag the cursor out of the original tab area. If flaps or their tabs seem wrongly positioned or lost, try issuing a restoreDisplay from the screen menu. The red-halo menu on a flap allows you to change the flap''s properties. For greatest ease of use, request ''keep this menu up'' here -- that way, you can easily explore all the options in the menu. tab color... Lets you change the color of the flap''s tab. flap color... Lets you change the color of the flap itself. use textual tab... If the tab is not textual, makes it become textual. change tab wording... If the tab is already textual, allows you to edit its wording. use graphical tab... If the tab is not graphical, makes it become graphical. choose tab graphic... If the tab is already graphical, allows you to change the picture. use solid tab... If the tab is not solid, makes it become solid, i.e. appear as a solid band of color along the entire length or width of the screen. parts-bin behavior If set, then dragging an object from the flap tears off a new copy of the object. dragover If set, the flap opens on dragover and closes again on drag-leave. mouseover If set, the flap opens on mouseover and closes again on mouse-leave. cling to edge... Governs which edge (left, right, top, bottom) the flap adheres to. shared If set, the same flap will be available in all projects; if not, the flap will will occur only in one project. destroy this flap Deletes the flap. To define a new flap, use ''make a new flap'', found in the ''flaps'' menu. To reinstate the default system flaps, you can use ''destroy all shared flaps'' from the ''flaps'' menu, and once they are destroyed, choose ''install default shared flaps''. To add, delete, or edit things on a given flap, it is often wise first to suspend the flap''s mouse-over and drag-over sensitivity, so it won''t keep disappearing on you while you''re trying to work with it. Besides the three standard flaps delivered with the default system, there are two other flaps readily available on demand from the ''flaps'' menu -- one is called ''Stack Tools'', which provides some tools useful for building stack-like content, the other is called ''Painting'', which provides a quick way to make a new painting. Simply clicking on the appropriate checkbox in the ''flaps'' menu will toggle the corresponding flap between being visible and not being visible in the project.'! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 4/24/2001 11:03'! addIndividualGlobalFlapItemsTo: aMenu "Add items governing the enablement of specific global flaps to aMenu" | anItem | self globalFlapTabsIfAny do: [:aFlapTab | anItem _ aMenu addUpdating: #globalFlapWithIDEnabledString: enablementSelector: #showSharedFlaps target: self selector: #enableDisableGlobalFlapWithID: argumentList: {aFlapTab flapID}. anItem wordingArgument: aFlapTab flapID. anItem setBalloonText: aFlapTab balloonTextForFlapsMenu].! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 6/11/2002 14:05'! enableEToyFlaps "Start using global flaps, plug-in version, given that they were not present." Cursor wait showWhile: [self addAndEnableEToyFlaps. self enableGlobalFlaps]! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 11/22/2001 11:15'! enableGlobalFlaps "Start using global flaps, given that they were not present." Cursor wait showWhile: [SharedFlapsAllowed _ true. self globalFlapTabs. "This will create them" Smalltalk isMorphic ifTrue: [ActiveWorld addGlobalFlaps. self doAutomaticLayoutOfFlapsIfAppropriate. FlapTab allInstancesDo: [:aTab | aTab computeEdgeFraction]. ActiveWorld reformulateUpdatingMenus]]! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 4/17/2001 13:50'! globalFlapWithIDEnabledString: aFlapID "Answer the string to be shown in a menu to represent the status of the givne flap regarding whether it it should be shown in this project." | aFlapTab wording | aFlapTab _ self globalFlapTabWithID: aFlapID. wording _ aFlapTab ifNotNil: [aFlapTab wording] ifNil: ['(', aFlapID, ')']. ^ (Project current isFlapIDEnabled: aFlapID) ifTrue: ['', wording] ifFalse: ['', wording]! ! !Flaps class methodsFor: 'menu support' stamp: 'dgd 8/31/2003 19:39'! setUpSuppliesFlapOnly "Set up the Supplies flap as the only shared flap. A special version formulated for this stand-alone use is used, defined in #newLoneSuppliesFlap" | supplies | SharedFlapTabs isEmptyOrNil ifFalse: "get rid of pre-existing guys if any" [SharedFlapTabs do: [:t | t referent delete. t delete]]. SharedFlapsAllowed _ true. SharedFlapTabs _ OrderedCollection new. SharedFlapTabs add: (supplies _ self newLoneSuppliesFlap). self enableGlobalFlapWithID: 'Supplies' translated. supplies setToPopOutOnMouseOver: false. Smalltalk isMorphic ifTrue: [ActiveWorld addGlobalFlaps. ActiveWorld reformulateUpdatingMenus]! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 5/4/2001 23:14'! showSharedFlaps "Answer whether shared flaps are currently showing. Presumably it is in service of Alan's wishes to have flaps show sometimes on interior subprojects and sometomes on outer projects that Bob's CurrentProjectRefactoring is threaded into the logic here." ^ CurrentProjectRefactoring showSharedFlaps! ! !Flaps class methodsFor: 'menu support' stamp: 'sw 5/5/2001 03:01'! suppressFlapsString "Answer the string to be shown in a menu to represent the suppress-flaps-in-this-project status" ^ CurrentProjectRefactoring suppressFlapsString! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 10:04'! automaticFlapLayoutChanged "Sent when the automaticFlapLayout preference changes. No senders in easily traceable in the image, but this is really sent by a Preference object!!" Preferences automaticFlapLayout ifTrue: [self positionNavigatorAndOtherFlapsAccordingToPreference]! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/22/2001 09:58'! doAutomaticLayoutOfFlapsIfAppropriate "Do automatic layout of flaps if appropriate" Preferences automaticFlapLayout ifTrue: [self positionNavigatorAndOtherFlapsAccordingToPreference]! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:26'! enableClassicNavigatorChanged "The #classicNavigatorEnabled preference has changed. No senders in easily traceable in the image, but this is really sent by a Preference object!!" Preferences classicNavigatorEnabled ifTrue: [Flaps disableGlobalFlapWithID: 'Navigator' translated. Preferences enable: #showProjectNavigator. self disableGlobalFlapWithID: 'Navigator' translated.] ifFalse: [self enableGlobalFlapWithID: 'Navigator' translated. ActiveWorld addGlobalFlaps]. self doAutomaticLayoutOfFlapsIfAppropriate. Project current assureNavigatorPresenceMatchesPreference. ActiveWorld reformulateUpdatingMenus! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sd 1/16/2004 21:33'! fileOutChanges "Bug workaround for squeak-flap 'fileOutChanges' buttons which for a while were mistakenly sending their requests here..." ^ ChangeSet current verboseFileOut. ! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'dgd 8/31/2003 19:28'! makeNavigatorFlapResembleGoldenBar "At explicit request, make the flap-based navigator resemble the golden bar. No senders in the image, but sendable from a doit" "Flaps makeNavigatorFlapResembleGoldenBar" Preferences setPreference: #classicNavigatorEnabled toValue: false. Preferences setPreference: #showProjectNavigator toValue: false. (self globalFlapTabWithID: 'Navigator' translated) ifNil: [SharedFlapTabs add: self newNavigatorFlap delete]. self enableGlobalFlapWithID: 'Navigator' translated. Preferences setPreference: #navigatorOnLeftEdge toValue: true. (self globalFlapTabWithID: 'Navigator' translated) arrangeToPopOutOnMouseOver: true. ActiveWorld addGlobalFlaps. self doAutomaticLayoutOfFlapsIfAppropriate. Project current assureNavigatorPresenceMatchesPreference. ! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sw 4/17/2001 13:24'! orientationForEdge: anEdge "Answer the orientation -- #horizontal or #vertical -- that corresponds to the edge symbol" ^ (#(left right) includes: anEdge) ifTrue: [#vertical] ifFalse: [#horizontal]! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sw 4/17/2001 13:24'! paintFlapButton "Answer a button to serve as the paint flap" | pb oldArgs brush myButton m | pb _ PaintBoxMorph new submorphNamed: #paint:. pb ifNil: [(brush _ Form extent: 16@16 depth: 16) fillColor: Color red] ifNotNil: [oldArgs _ pb arguments. brush _ oldArgs third. brush _ brush copy: (2@0 extent: 42@38). brush _ brush scaledToSize: brush extent // 2]. myButton _ BorderedMorph new. myButton color: (Color r: 0.833 g: 0.5 b: 0.0); borderWidth: 2; borderColor: #raised. myButton addMorph: (m _ brush asMorph lock). myButton extent: m extent + (myButton borderWidth + 6). m position: myButton center - (m extent // 2). ^ myButton ! ! !Flaps class methodsFor: 'miscellaneous' stamp: 'sw 11/6/2000 14:23'! removeFromGlobalFlapTabList: aFlapTab "If the flap tab is in the global list, remove it" SharedFlapTabs remove: aFlapTab ifAbsent: []! ! !Flaps class methodsFor: 'new flap' stamp: 'dgd 8/31/2003 18:58'! addLocalFlap "Menu command -- let the user add a new project-local flap. Once the new flap is born, the user can tell it to become a shared flap. Obtain an initial name and edge for the flap, launch the flap, and also launch a menu governing the flap, so that the user can get started right away with customizing it." | aMenu reply aFlapTab aWorld edge | aMenu _ MVCMenuMorph entitled: 'Where should the new flap cling?' translated. aMenu defaultTarget: aMenu. #(left right top bottom) do: [:sym | aMenu add: sym asString translated selector: #selectMVCItem: argument: sym]. edge _ aMenu invokeAt: self currentHand position in: self currentWorld. edge ifNotNil: [reply _ FillInTheBlank request: 'Wording for this flap: ' translated initialAnswer: 'Flap' translated. reply isEmptyOrNil ifFalse: [aFlapTab _ self newFlapTitled: reply onEdge: edge. (aWorld _ self currentWorld) addMorphFront: aFlapTab. aFlapTab adaptToWorld: aWorld. aMenu _ aFlapTab buildHandleMenu: ActiveHand. aFlapTab addTitleForHaloMenu: aMenu. aFlapTab computeEdgeFraction. aMenu popUpEvent: ActiveEvent in: ActiveWorld]] ! ! !Flaps class methodsFor: 'new flap' stamp: 'sw 5/4/2001 23:59'! defaultColorForFlapBackgrounds "Answer the color to use, by default, in new flap backgrounds" ^ (Color blue mixed: 0.8 with: Color white) alpha: 0.6! ! !Flaps class methodsFor: 'new flap' stamp: 'sw 4/17/2001 13:24'! newFlapTitled: aString onEdge: anEdge "Create a new flap with the given title and place it on the given edge" ^ self newFlapTitled: aString onEdge: anEdge inPasteUp: self currentWorld ! ! !Flaps class methodsFor: 'new flap' stamp: 'di 11/19/2001 21:07'! newFlapTitled: aString onEdge: anEdge inPasteUp: aPasteUpMorph "Add a flap with the given title, placing it on the given edge, in the given pasteup" | aFlapBody aFlapTab | aFlapBody _ PasteUpMorph newSticky. aFlapTab _ FlapTab new referent: aFlapBody. aFlapTab setName: aString edge: anEdge color: (Color r: 0.516 g: 0.452 b: 1.0). anEdge == #left ifTrue: [aFlapTab position: (aPasteUpMorph left @ aPasteUpMorph top). aFlapBody extent: (200 @ aPasteUpMorph height)]. anEdge == #right ifTrue: [aFlapTab position: ((aPasteUpMorph right - aFlapTab width) @ aPasteUpMorph top). aFlapBody extent: (200 @ aPasteUpMorph height)]. anEdge == #top ifTrue: [aFlapTab position: ((aPasteUpMorph left + 50) @ aPasteUpMorph top). aFlapBody extent: (aPasteUpMorph width @ 200)]. anEdge == #bottom ifTrue: [aFlapTab position: ((aPasteUpMorph left + 50) @ (aPasteUpMorph bottom - aFlapTab height)). aFlapBody extent: (aPasteUpMorph width @ 200)]. aFlapBody beFlap: true. aFlapBody color: self defaultColorForFlapBackgrounds. ^ aFlapTab! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 18:59'! addAndEnableEToyFlaps "Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed." | aSuppliesFlap | SharedFlapTabs ifNotNil: [^ self]. SharedFlapTabs _ OrderedCollection new. aSuppliesFlap _ self newSuppliesFlapFromQuads: self quadsDefiningPlugInSuppliesFlap positioning: #right. aSuppliesFlap referent setNameTo: 'Supplies Flap' translated. "Per request from Kim Rose, 7/19/02" SharedFlapTabs add: aSuppliesFlap. "The #center designation doesn't quite work at the moment" SharedFlapTabs add: self newNavigatorFlap. self enableGlobalFlapWithID: 'Supplies' translated. self enableGlobalFlapWithID: 'Navigator' translated. SharedFlapsAllowed _ true. Project current flapsSuppressed: false. ^ SharedFlapTabs "Flaps addAndEnableEToyFlaps"! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 18:44'! addNewDefaultSharedFlaps "Add the stack tools flap and the navigator flap to the global list, but do not have them showing initially. Transitional, called by the postscript of the FlapsOnBottom update; probably dispensable afterwards." SharedFlapTabs ifNotNil: [(self globalFlapTabWithID: 'Stack Tools' translated) ifNil: [SharedFlapTabs add: self newStackToolsFlap delete]. self enableGlobalFlapWithID: 'Stack Tools' translated. (self globalFlapTabWithID: 'Navigator' translated) ifNil: [SharedFlapTabs add: self newNavigatorFlap delete]. self enableGlobalFlapWithID: 'Navigator' translated. self currentWorld addGlobalFlaps]! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 9/3/2004 12:56'! addStandardFlaps "Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed. " SharedFlapTabs ifNil: [SharedFlapTabs := OrderedCollection new]. SharedFlapTabs add: self newSqueakFlap. SharedFlapTabs add: self newSuppliesFlap. SharedFlapTabs add: self newToolsFlap. SharedFlapTabs add: self newWidgetsFlap. SharedFlapTabs add: self newStackToolsFlap. SharedFlapTabs add: self newNavigatorFlap. SharedFlapTabs add: self newPaintingFlap. SharedFlapTabs add: self newObjectsFlap. self disableGlobalFlapWithID: 'Stack Tools' translated. self disableGlobalFlapWithID: 'Painting' translated. self disableGlobalFlapWithID: 'Navigator' translated. self disableGlobalFlapWithID: 'Objects' translated. ^ SharedFlapTabs! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 9/2/2004 15:49'! defaultsQuadsDefiningPlugInSuppliesFlap "Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image" ^ #( (ObjectsTool newStandAlone 'Object Catalog' 'A tool that lets you browse the catalog of available objects') (AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'Stop, Step, and Go buttons for controlling all your scripts at once. The tool can also be "opened up" to control each script in your project individually.') (TrashCanMorph new 'Trash' 'A tool for discarding objects') (GrabPatchMorph new 'Grab Patch' 'Allows you to create a new Sketch by grabbing a rectangular patch from the screen') (LassoPatchMorph new 'Lasso' 'Allows you to create a new Sketch by lassoing an area from the screen') (StickyPadMorph newStandAlone 'Sticky Pad' 'Each time you obtain one of these pastel, translucent, borderless rectangles, it will be a different color from the previous time.') "(PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there')" (TextMorph boldAuthoringPrototype 'Text' 'Text that you can edit into anything you desire.') (RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') (RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') (RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') (EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') (StarMorph authoringPrototype 'Star' 'A star') (CurveMorph authoringPrototype 'Curve' 'A curve') (PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') (ScriptableButton authoringPrototype 'Button' 'A Scriptable button') (BookMorph nextPageButton 'NextPage' 'A button that takes you to the next page') (BookMorph previousPageButton 'PreviousPage' 'A button that takes you to the previous page') (ScriptingSystem prototypicalHolder 'Holder' 'A place for storing alternative pictures in an animation, etc.') (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') (BookMorph authoringPrototype 'Book' 'A multi-paged structure') (ClockMorph authoringPrototype 'Clock' 'A simple digital clock') (RandomNumberTile new 'Random' 'A random-number tile for use with tile scripting')) asOrderedCollection! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'sw 8/12/2001 16:55'! initializeStandardFlaps "Initialize the standard default out-of-box set of global flaps. This method creates them and places them in my class variable #SharedFlapTabs, but does not itself get them displayed." SharedFlapTabs _ nil. self addStandardFlaps! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:37'! newLoneSuppliesFlap "Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen, for use when it is the only flap shown upon web launch" | aFlapTab aStrip leftEdge | "Flaps setUpSuppliesFlapOnly" aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color red muchLighter from: #( (TrashCanMorph new 'Trash' 'A tool for discarding objects') (ScriptingSystem scriptControlButtons 'Status' 'Buttons to run, stop, or single-step scripts') (AllScriptsTool allScriptsToolForActiveWorld 'All Scripts' 'A tool that lets you control all the running scripts in your world') (PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') (RectangleMorph authoringPrototype 'Rectangle' 'A rectangle' ) (RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') (EllipseMorph authoringPrototype 'Ellipse' 'An ellipse or circle') (StarMorph authoringPrototype 'Star' 'A star') (CurveMorph authoringPrototype 'Curve' 'A curve') (PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') (TextMorph authoringPrototype 'Text' 'Text that you can edit into anything you desire.') (SimpleSliderMorph authoringPrototype 'Slider' 'A slider for showing and setting numeric values.') (JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') (ScriptingSystem prototypicalHolder 'Holder' 'A place for storing alternative pictures in an animation, ec.') (ScriptableButton authoringPrototype 'Button' 'A Scriptable button') (PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') (BookMorph authoringPrototype 'Book' 'A multi-paged structure') (TabbedPalette authoringPrototype 'Tabs' 'A structure with tabs') (RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') (MagnifierMorph newRound 'Magnifier' 'A magnifying glass') (ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') (ClockMorph authoringPrototype 'Clock' 'A simple digital clock') (BookMorph previousPageButton 'Previous' 'A button that takes you to the previous page') (BookMorph nextPageButton 'Next' 'A button that takes you to the next page') ). aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Supplies' translated edge: #bottom color: Color red lighter. aStrip extent: self currentWorld width @ 78. leftEdge _ ((Display width - (16 + aFlapTab width)) + 556) // 2. aFlapTab position: (leftEdge @ (self currentWorld height - aFlapTab height)). aStrip beFlap: true. aStrip autoLineLayout: true. ^ aFlapTab! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:03'! newNavigatorFlap "Answer a newly-created flap which adheres to the bottom edge of the screen and which holds the project navigator controls. " | aFlapTab navBar aFlap | navBar _ ProjectNavigationMorph preferredNavigator new. aFlap _ PasteUpMorph newSticky borderWidth: 0; extent: navBar extent + (0@20); color: (Color orange alpha: 0.8); beFlap: true; addMorph: navBar beSticky. aFlap hResizing: #shrinkWrap; vResizing: #shrinkWrap. aFlap useRoundedCorners. aFlap setNameTo: 'Navigator Flap' translated. navBar fullBounds. "to establish width" aFlapTab _ FlapTab new referent: aFlap. aFlapTab setName: 'Navigator' translated edge: #bottom color: Color orange. aFlapTab position: ((navBar width // 2) - (aFlapTab width // 2)) @ (self currentWorld height - aFlapTab height). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Navigator' translated " ! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 9/3/2004 12:51'! newObjectsFlap "Answer a fully-instantiated flap named 'Objects' to be placed at the top of the screen." | aFlapTab anObjectsTool | anObjectsTool _ ObjectsTool new. anObjectsTool initializeForFlap. aFlapTab _ FlapTab new referent: anObjectsTool beSticky. aFlapTab setName: 'Objects' translated edge: #top color: Color red lighter. aFlapTab position: ((Display width - (aFlapTab width + 22)) @ 0). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. anObjectsTool extent: self currentWorld width @ 200. anObjectsTool beFlap: true. anObjectsTool color: Color red muchLighter. anObjectsTool clipSubmorphs: true. anObjectsTool showCategories. ^ aFlapTab! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'dgd 8/31/2003 19:50'! newPaintingFlap "Add a flap with the paint palette in it" | aFlap aFlapTab | "Flaps reinstateDefaultFlaps. Flaps addPaintingFlap" aFlap _ PasteUpMorph new borderWidth: 0. aFlap color: Color transparent. aFlap layoutPolicy: TableLayout new. aFlap hResizing: #shrinkWrap. aFlap vResizing: #shrinkWrap. aFlap cellPositioning: #topLeft. aFlap clipSubmorphs: false. aFlap beSticky. "really?!!" aFlap addMorphFront: PaintBoxMorph new. aFlap setProperty: #flap toValue: true. aFlap fullBounds. "force layout" aFlapTab _ FlapTab new referent: aFlap. aFlapTab setNameTo: 'Painting' translated. aFlapTab setProperty: #priorWording toValue: 'Paint' translated. aFlapTab useGraphicalTab. aFlapTab removeAllMorphs. aFlapTab setProperty: #paintingFlap toValue: true. aFlapTab addMorphFront: "(SketchMorph withForm: (ScriptingSystem formAtKey: #PaintingFlapPic))" self paintFlapButton. aFlapTab cornerStyle: #rounded. aFlapTab edgeToAdhereTo: #right. aFlapTab setToPopOutOnDragOver: false. aFlapTab setToPopOutOnMouseOver: false. aFlapTab on: #mouseUp send: #startOrFinishDrawing: to: aFlapTab. aFlapTab setBalloonText:'Click here to start or finish painting.' translated. aFlapTab fullBounds. "force layout" aFlapTab position: (0@6). self currentWorld addMorphFront: aFlapTab. ^ aFlapTab! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 7/29/2004 10:12'! newSqueakFlap "Answer a new default 'Squeak' flap for the left edge of the screen" | aFlap aFlapTab aButton aClock buttonColor anOffset bb aFont | aFlap _ PasteUpMorph newSticky borderWidth: 0. aFlapTab _ FlapTab new referent: aFlap. aFlapTab setName: 'Squeak' translated edge: #left color: Color brown lighter lighter. aFlapTab position: (0 @ ((Display height - aFlapTab height) // 2)). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aFlap cellInset: 14@14. aFlap beFlap: true. aFlap color: (Color brown muchLighter lighter "alpha: 0.3"). aFlap extent: 150 @ self currentWorld height. aFlap layoutPolicy: TableLayout new. aFlap wrapCentering: #topLeft. aFlap layoutInset: 2. aFlap listDirection: #topToBottom. aFlap wrapDirection: #leftToRight. "self addProjectNavigationButtonsTo: aFlap." anOffset _ 16. aClock _ ClockMorph newSticky. aClock color: Color red. aClock showSeconds: false. aClock font: (TextStyle default fontAt: 3). aClock step. aClock setBalloonText: 'The time of day. If you prefer to see seconds, check out my menu.' translated. aFlap addCenteredAtBottom: aClock offset: anOffset. buttonColor _ Color cyan muchLighter. bb _ SimpleButtonMorph new target: SmalltalkImage current. bb color: buttonColor. aButton _ bb copy. aButton actionSelector: #saveSession. aButton setBalloonText: 'Make a complete snapshot of the current state of the image onto disk.' translated. aButton label: 'save' translated font: (aFont _ ScriptingSystem fontForTiles). aFlap addCenteredAtBottom: aButton offset: anOffset. aButton _ bb copy target: Utilities. aButton actionSelector: #updateFromServer. aButton label: 'load code updates' translated font: aFont. aButton color: buttonColor. aButton setBalloonText: 'Check the Squeak server for any new code updates, and load any that are found.' translated. aFlap addCenteredAtBottom: aButton offset: anOffset. aButton _ SimpleButtonMorph new target: SmalltalkImage current; actionSelector: #aboutThisSystem; label: 'about this system' translated font: aFont. aButton color: buttonColor. aButton setBalloonText: 'click here to find out version information' translated. aFlap addCenteredAtBottom: aButton offset: anOffset. aFlap addCenteredAtBottom: (Preferences themeChoiceButtonOfColor: buttonColor font: aFont) offset: anOffset. aButton _ TrashCanMorph newSticky. aFlap addCenteredAtBottom: aButton offset: anOffset. aButton startStepping. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Squeak' translated "! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:39'! newStackToolsFlap "Add a flap with stack tools in it" | aFlapTab aStrip | aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: (Color red muchLighter "alpha: 0.2") from: self quadsDefiningStackToolsFlap. aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Stack Tools' translated edge: #bottom color: Color brown lighter lighter. aFlapTab position: ((Display width - (aFlapTab width + 226)) @ (self currentWorld height - aFlapTab height)). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aStrip extent: self currentWorld width @ 78. aStrip beFlap: true. aStrip autoLineLayout: true. aStrip extent: self currentWorld width @ 70. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Stack Tools' translated"! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'sw 6/11/2002 14:00'! newSuppliesFlap "Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen; this is for the non-plug-in-version" ^ self newSuppliesFlapFromQuads: self quadsDefiningSuppliesFlap positioning: #right! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:39'! newSuppliesFlapFromQuads: quads positioning: positionSymbol "Answer a fully-instantiated flap named 'Supplies' to be placed at the bottom of the screen. Use #center as the positionSymbol to have it centered at the bottom of the screen, or #right to have it placed off near the right edge." | aFlapTab aStrip hPosition | aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: Color red muchLighter from: quads. self twiddleSuppliesButtonsIn: aStrip. aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Supplies' translated edge: #bottom color: Color red lighter. hPosition _ positionSymbol == #center ifTrue: [(Display width // 2) - (aFlapTab width // 2)] ifFalse: [Display width - (aFlapTab width + 22)]. aFlapTab position: (hPosition @ (self currentWorld height - aFlapTab height)). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aStrip extent: self currentWorld width @ 78. aStrip beFlap: true. aStrip autoLineLayout: true. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Supplies' translated"! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:39'! newToolsFlap "Answer a newly-created flap which adheres to the right edge of the screen and which holds prototypes of standard tools." | aFlapTab aStrip | aStrip _ PartsBin newPartsBinWithOrientation: #topToBottom andColor: (Color orange muchLighter alpha: 0.8) from: self quadsDefiningToolsFlap. aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Tools' translated edge: #right color: Color orange lighter. aFlapTab position: (self currentWorld width - aFlapTab width) @ ((Display height - aFlapTab height) // 2). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aStrip extent: (90 @ self currentWorld height). aStrip beFlap: true. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Tools' translated " ! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'nk 8/6/2004 11:40'! newWidgetsFlap "Answer a newly-created flap which adheres to the bottom edge of the screen and which holds prototypes of standard widgets. " | aFlapTab aStrip | aStrip _ PartsBin newPartsBinWithOrientation: #leftToRight andColor: (Color blue muchLighter alpha: 0.8) from: self quadsDefiningWidgetsFlap. aFlapTab _ FlapTab new referent: aStrip beSticky. aFlapTab setName: 'Widgets' translated edge: #bottom color: Color blue lighter lighter. aFlapTab position: ((Display width - (aFlapTab width + 122)) @ (self currentWorld height - aFlapTab height)). aFlapTab setBalloonText: aFlapTab balloonTextForFlapsMenu. aStrip extent: self currentWorld width @ 78. aStrip beFlap: true. aStrip autoLineLayout: true. ^ aFlapTab "Flaps replaceGlobalFlapwithID: 'Widgets' translated " ! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'sw 3/3/2004 13:38'! quadsDefiningPlugInSuppliesFlap "Answer a list of quads which define the objects to appear in the default Supplies flap used in the Plug-in image" ^ self registeredFlapsQuadsAt: 'PlugIn Supplies'! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:25'! quadsDefiningStackToolsFlap "Answer a structure defining the items on the default system Stack Tools flap" ^ self registeredFlapsQuadsAt: 'Stack Tools' "Flaps replaceGlobalFlapwithID: 'Stack Tools'"! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! quadsDefiningSuppliesFlap "Answer a list of quads which define the objects to appear in the default Supplies flap" ^ self registeredFlapsQuadsAt: 'Supplies'! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:51'! quadsDefiningToolsFlap "Answer a structure defining the default Tools flap" ^ self registeredFlapsQuadsAt: 'Tools'! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! quadsDefiningWidgetsFlap "Answer a structure defining the default Widgets flap" ^ self registeredFlapsQuadsAt: 'Widgets'! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'asm 3/13/2003 10:26'! quadsDeiningScriptingFlap "Answer a structure defining the default items in the Scripting flap" ^ self registeredFlapsQuadsAt: 'Scripting'! ! !Flaps class methodsFor: 'predefined flaps' stamp: 'sw 4/3/2003 16:35'! twiddleSuppliesButtonsIn: aStrip "Munge item(s) in the strip whose names as seen in the parts bin should be different from the names to be given to resulting torn-off instances" (aStrip submorphs detect: [:m | m target == StickyPadMorph] ifNone: [nil]) ifNotNilDo: [:aButton | aButton arguments: {#newStandAlone. 'tear off'}]! ! !Flaps class methodsFor: 'replacement' stamp: 'sw 7/25/2004 00:56'! replaceGlobalFlapwithID: flapID "If there is a global flap with flapID, replace it with an updated one." | replacement tabs | (tabs _ self globalFlapTabsWithID: flapID) size = 0 ifTrue: [^ self]. tabs do: [:tab | self removeFlapTab: tab keepInList: false]. flapID = 'Stack Tools' translated ifTrue: [replacement _ self newStackToolsFlap]. flapID = 'Supplies' translated ifTrue: [replacement _ self newSuppliesFlapFromQuads: (Preferences eToyFriendly ifFalse: [self quadsDefiningSuppliesFlap] ifTrue: [self quadsDefiningPlugInSuppliesFlap]) positioning: #right]. flapID = 'Tools' translated ifTrue: [replacement _ self newToolsFlap]. flapID = 'Widgets' translated ifTrue: [replacement _ self newWidgetsFlap]. flapID = 'Navigator' translated ifTrue: [replacement _ self newNavigatorFlap]. flapID = 'Squeak' translated ifTrue: [replacement _ self newSqueakFlap]. replacement ifNil: [^ self]. self addGlobalFlap: replacement. self currentWorld ifNotNil: [self currentWorld addGlobalFlaps] "Flaps replaceFlapwithID: 'Widgets' translated "! ! !Flaps class methodsFor: 'replacement' stamp: 'sw 5/3/1999 22:44'! replacePartSatisfying: elementBlock inGlobalFlapSatisfying: flapBlock with: replacement "If any global flap satisfies flapBlock, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc." | aFlapTab flapPasteUp anElement | aFlapTab _ self globalFlapTabsIfAny detect: [:aTab | flapBlock value: aTab] ifNone: [^ self]. flapPasteUp _ aFlapTab referent. anElement _ flapPasteUp submorphs detect: [:aMorph | elementBlock value: aMorph] ifNone: [^ self]. flapPasteUp replaceSubmorph: anElement by: replacement. flapPasteUp replaceTallSubmorphsByThumbnails; setPartsBinStatusTo: true. "Flaps replacePartSatisfying: [:el | (el isKindOf: MorphThumbnail) and: [(el morphRepresented isKindOf: SystemWindow) and: [el morphRepresented label = 'scripting area']]] inGlobalFlapSatisfying: [:fl | (fl submorphs size > 0) and: [(fl submorphs first isKindOf: TextMorph) and: [(fl submorphs first contents string copyWithout: Character cr) = 'Tools']]] with: ScriptingSystem newScriptingSpace"! ! !Flaps class methodsFor: 'replacement' stamp: 'sw 4/17/2001 13:15'! replacePartSatisfying: elementBlock inGlobalFlapWithID: aFlapID with: replacement "If a global flapl exists with the given flapID, look in it for a part satisfying elementBlock; if such a part is found, replace it with the replacement morph, make sure the flap's layout is made right, etc." ^ self replacePartSatisfying: elementBlock inGlobalFlapSatisfying: [:fl | fl flapID = aFlapID] with: replacement! ! !Flaps class methodsFor: 'replacement' stamp: 'dgd 8/31/2003 19:41'! replaceToolsFlap "if there is a global tools flap, replace it with an updated one." self replaceGlobalFlapwithID: 'Tools' translated "Flaps replaceToolsFlap"! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/17/2001 13:31'! addGlobalFlap: aFlapTab "Add the given flap tab to the list of shared flaps" SharedFlapTabs ifNil: [SharedFlapTabs _ OrderedCollection new]. SharedFlapTabs add: aFlapTab! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 7/24/2001 22:01'! enableOnlyGlobalFlapsWithIDs: survivorList "In the current project, suppress all global flaps other than those with ids in the survivorList" self globalFlapTabsIfAny do: [:aFlapTab | (survivorList includes: aFlapTab flapID) ifTrue: [self enableGlobalFlapWithID: aFlapTab flapID] ifFalse: [self disableGlobalFlapWithID: aFlapTab flapID]]. ActiveWorld addGlobalFlaps "Flaps enableOnlyGlobalFlapsWithIDs: #('Supplies')"! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:34'! globalFlapTab: aName "Answer the global flap tab in the current system whose flapID is the same as aName, or nil if none found." | idToMatch | idToMatch _ (aName beginsWith: 'flap: ') ifTrue: "Ted's old scheme; this convention may still be found in pre-existing content that has been externalized" [aName copyFrom: 7 to: aName size] ifFalse: [aName]. ^ self globalFlapTabsIfAny detect: [:ft | ft flapID = idToMatch] ifNone: [nil]! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/27/2001 16:36'! globalFlapTabOrDummy: aName "Answer a global flap tab in the current image with the given name. If none is found, answer a dummy StringMorph for some reason (check with tk about the use of this)" | gg | (gg _ self globalFlapTab: aName) ifNil: [^ StringMorph contents: aName, ' can''t be found']. ^ gg! ! !Flaps class methodsFor: 'shared flaps' stamp: 'di 11/19/2001 22:07'! globalFlapTabWithID: aFlapID "answer the global flap tab with the given id, or nil if none" ^ self globalFlapTabsIfAny detect: [:aFlapTab | aFlapTab flapID = aFlapID] ifNone: ["Second try allows sequence numbers" self globalFlapTabsIfAny detect: [:aFlapTab | FlapTab givenID: aFlapTab flapID matches: aFlapID] ifNone: [nil]]! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 5/5/2001 02:41'! globalFlapTabs "Answer the list of shared flap tabs, creating it if necessary. Much less aggressive is #globalFlapTabsIfAny" SharedFlapTabs ifNil: [self initializeStandardFlaps]. ^ SharedFlapTabs copy! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/23/2001 18:04'! globalFlapTabsIfAny "Answer a list of the global flap tabs, but it they don't exist, just answer an empty list" ^ SharedFlapTabs copy ifNil: [Array new]! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/8/2002 08:41'! globalFlapTabsWithID: aFlapID "Answer all flap tabs whose ids start with the given id" ^ self globalFlapTabsIfAny select: [:aFlapTab | (aFlapTab flapID = aFlapID) or: [FlapTab givenID: aFlapTab flapID matches: aFlapID]] "Flaps globalFlapTabsWithID: 'Stack Tools'"! ! !Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:27'! positionNavigatorAndOtherFlapsAccordingToPreference "Lay out flaps along the designated edge right-to-left, possibly positioning the navigator flap, exceptionally, on the left." | ids | ids _ Preferences navigatorOnLeftEdge ifTrue: [{'Navigator' translated}] ifFalse: [#()]. Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapsWithIDs: ids "Flaps positionNavigatorAndOtherFlapsAccordingToPreference"! ! !Flaps class methodsFor: 'shared flaps' stamp: 'dgd 8/31/2003 19:29'! positionVisibleFlapsRightToLeftOnEdge: edgeSymbol butPlaceAtLeftFlapsWithIDs: idList "Lay out flaps along the designated edge right-to-left, while laying left-to-right any flaps found in the exception list Flaps positionVisibleFlapsRightToLeftOnEdge: #bottom butPlaceAtLeftFlapWithIDs: {'Navigator' translated. 'Supplies' translated} Flaps sharedFlapsAlongBottom" | leftX flapList flapsOnRight flapsOnLeft | flapList _ self globalFlapTabsIfAny select: [:aFlapTab | aFlapTab isInWorld and: [aFlapTab edgeToAdhereTo == edgeSymbol]]. flapsOnLeft _ flapList select: [:fl | idList includes: fl flapID]. flapList removeAll: flapsOnLeft. flapsOnRight _ flapList asSortedCollection: [:f1 :f2 | f1 left > f2 left]. leftX _ ActiveWorld width - 15. flapsOnRight do: [:aFlapTab | aFlapTab right: leftX - 3. leftX _ aFlapTab left]. leftX _ ActiveWorld left. flapsOnLeft _ flapsOnLeft asSortedCollection: [:f1 :f2 | f1 left > f2 left]. flapsOnLeft do: [:aFlapTab | aFlapTab left: leftX + 3. leftX _ aFlapTab right]. (flapsOnLeft asOrderedCollection, flapsOnRight asOrderedCollection) do: [:ft | ft computeEdgeFraction. ft flapID = 'Navigator' translated ifTrue: [ft referent left: (ft center x - (ft referent width//2) max: 0)]] ! ! !Flaps class methodsFor: 'shared flaps' stamp: 'mir 8/24/2001 20:42'! removeDuplicateFlapTabs "Remove flaps that were accidentally added multiple times" "Flaps removeDuplicateFlapTabs" | tabs duplicates same | SharedFlapTabs copy ifNil: [^self]. tabs _ SharedFlapTabs copy. duplicates _ Set new. tabs do: [:tab | same _ tabs select: [:each | each wording = tab wording]. same isEmpty not ifTrue: [ same removeFirst. duplicates addAll: same]]. SharedFlapTabs removeAll: duplicates! ! !Flaps class methodsFor: 'shared flaps' stamp: 'sw 4/24/2001 11:17'! sharedFlapsAllowed "Answer whether the shared flaps feature is allowed in this system" ^ SharedFlapsAllowed ifNil: [SharedFlapsAllowed _ SharedFlapTabs isEmptyOrNil not]! ! !Flaps class methodsFor: 'shared flaps' stamp: 'dgd 10/7/2003 22:47'! sharedFlapsAlongBottom "Put all shared flaps (except Painting which can't be moved) along the bottom" "Flaps sharedFlapsAlongBottom" | leftX unordered ordered | unordered _ self globalFlapTabsIfAny asIdentitySet. ordered _ Array streamContents: [:s | { 'Squeak' translated. 'Navigator' translated. 'Supplies' translated. 'Widgets' translated. 'Stack Tools' translated. 'Tools' translated. 'Painting' translated. } do: [:id | (self globalFlapTabWithID: id) ifNotNilDo: [:ft | unordered remove: ft. id = 'Painting' translated ifFalse: [s nextPut: ft]]]]. "Pace off in order from right to left, setting positions" leftX _ Display width-15. ordered , unordered asArray reverseDo: [:ft | ft setEdge: #bottom. ft right: leftX - 3. leftX _ ft left]. "Put Nav Bar centered under tab if possible" (self globalFlapTabWithID: 'Navigator' translated) ifNotNilDo: [:ft | ft referent left: (ft center x - (ft referent width//2) max: 0)]. self positionNavigatorAndOtherFlapsAccordingToPreference. ! ! !Flaps class methodsFor: 'class initialization' stamp: 'nk 6/14/2004 08:37'! initialize self initializeFlapsQuads! ! !FlapsTest methodsFor: 'initialize-release' stamp: 'cE 10/10/2003 19:08'! setUp "I am the method in which your test is initialized. If you have ressources to build, put them here."! ! !FlapsTest methodsFor: 'initialize-release' stamp: 'cE 10/10/2003 19:08'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !FlapsTest methodsFor: 'testing' stamp: 'cE 10/12/2003 19:54'! testRegisteredFlapsQuads "Defaults are defined in Flaps class>>defaultQuadsDefining... If you change something there, do the following afterwards: Flaps initializeFlapsQuads" | allQuads absentClasses absentSelectors | allQuads _ OrderedCollection new. absentClasses _ OrderedCollection new. Flaps registeredFlapsQuads valuesDo: [:each | allQuads addAll: each]. allQuads do: [:each | | theObject | theObject _ each at: 1. Smalltalk at: theObject ifAbsent: [absentClasses add: each]]. self assert: absentClasses isEmpty description: 'There are absent classes: ' , absentClasses asString. absentSelectors _ OrderedCollection new. allQuads do: [:each | | theClass theSelector | theClass _ (Smalltalk at: (each at: 1)) class. theSelector _ each at: 2. (theClass canUnderstand: theSelector) ifFalse: [absentSelectors add: each]]. self assert: absentSelectors isEmpty description: 'There are absent selectors: ' , absentSelectors asString! ! !FlapsTest commentStamp: '' prior: 0! A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs. When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp. When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.! !FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'nk 8/30/2004 07:49'! compress (points isOctetString) ifFalse:[ points _ FlashCodec compress: self. leftFills _ rightFills _ lineWidths _ lineFills _ fillStyles _ nil].! ! !FlashBoundaryShape methodsFor: 'disk i/o' stamp: 'nk 8/30/2004 07:49'! decompress | newShape | (points isOctetString) ifTrue:[ newShape _ FlashCodec decompress: (ReadStream on: points). points _ newShape points. leftFills _ newShape leftFills. rightFills _ newShape rightFills. lineWidths _ newShape lineWidths. lineFills _ newShape lineFills. fillStyles _ newShape fillStyles].! ! !FlashButtonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'set custom action' translated action: #addCustomAction. aCustomMenu add: 'remove all actions' translated action: #removeActions. ! ! !FlashCharacterMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:41'! addCustomMenuItems: aMenu hand: aHand super addCustomMenuItems: aMenu hand: aHand. aMenu add:'add project target' translated action: #addProjectTarget. aMenu add:'remove project target' translated action: #removeProjectTarget.! ! !FlashCodec class methodsFor: 'compressing' stamp: 'nk 7/30/2004 21:51'! compressPoints: points ^(self new compressPoints: points) contents! ! !FlashFileReader methodsFor: 'reading' stamp: 'sd 1/30/2004 15:17'! processFileContents "Process the contents of the flash file. Assume that the header has been read before." | time | time _ Time millisecondsToRun:[ self isStreaming ifTrue:[ "Don't show progress for a streaming connection. Note: Yielding is done someplace else." [self processTagFrom: stream] whileTrue. ] ifFalse:[ 'Reading file' displayProgressAt: Sensor cursorPoint from: 1 to: 100 during:[:theBar| [self processTagFrom: stream] whileTrue:[ theBar value: (stream position * 100 // stream size). stream atEnd ifTrue:[ log ifNotNil:[ log cr; nextPutAll:'Unexpected end of data (no end tag)'. self flushLog]. ^self]]. ]. ]. stream close. ]. Transcript cr; print: time / 1000.0; show:' secs to read file'! ! !FlashFileReader methodsFor: 'reading' stamp: 'dgd 9/21/2003 17:38'! processHeader "Read header information from the source stream. Return true if successful, false otherwise." | twipsFrameSize frameRate frameCount | self processSignature ifFalse:[^false]. version _ stream nextByte. "Check for the version supported" version > self maximumSupportedVersion ifTrue:[ (self confirm:('This file''s version ({1}) is higher than the currently supported version ({2}). It may contain features that are not supported and it may not display correctly. Do you want to continue?' translated format:{version. self maximumSupportedVersion})) ifFalse:[^false]]. dataSize _ stream nextLong. "Check for the minimal file size" dataSize < 21 ifTrue:[^false]. twipsFrameSize _ stream nextRect. self recordGlobalBounds: twipsFrameSize. frameRate _ stream nextWord / 256.0. self recordFrameRate: frameRate. frameCount _ stream nextWord. self recordFrameCount: frameCount. log ifNotNil:[ log cr; nextPutAll:'------------- Header information --------------'. log cr; nextPutAll:'File version '; print: version. log cr; nextPutAll:'File size '; print: dataSize. log cr; nextPutAll:'Movie width '; print: twipsFrameSize extent x // 20. log cr; nextPutAll:'Movie height '; print: twipsFrameSize extent y // 20. log cr; nextPutAll:'Frame rate '; print: frameRate. log cr; nextPutAll:'Frame count '; print: frameCount. log cr; cr. self flushLog]. ^true! ! !FlashFileReader methodsFor: 'processing actions' stamp: 'ar 5/4/2001 16:21'! processActionWaitForFrame: data | length frame skip | length _ data nextWord. length = 3 ifFalse:["Something is wrong" data skip: -2. ^self processUnknownAction: data]. frame _ data nextWord. skip _ data nextByte. log ifNotNil:[ log nextPutAll:'frame = '; print: frame; nextPutAll:', skip = '; print: skip]. ^Message selector: #isFrameLoaded:elseSkip: arguments: (Array with: frame with: skip).! ! !FlashFileReader methodsFor: 'processing tags' stamp: 'mir 6/11/2001 13:06'! processDefineBitsJPEG2: data | id image decoder | id _ data nextWord. decoder _ FlashJPEGDecoder new. decoder isStreaming: self isStreaming. decoder decodeJPEGTables: data. data atEnd ifFalse: [ image _ decoder decodeNextImageFrom: data. Preferences compressFlashImages ifTrue:[image _ image asFormOfDepth: 8]. self recordBitmap: id data: image]. ^true! ! !FlashFileReader methodsFor: 'private' stamp: 'ar 5/4/2001 16:22'! maximumSupportedVersion ^3! ! !FlashJPEGDecoder methodsFor: 'decoding' stamp: 'RAA 8/21/2001 23:15'! decodeJPEGTables: aStream " fixing the #atEnd allows the following to work: (FlashMorphReader on: (HTTPSocket httpGet: 'http://www.audi.co.uk/flash/intro1.swf' accept:'application/x-shockwave-flash')) processFile startPlaying openInWorld. " self setStream: aStream. eoiSeen _ false. self parseFirstMarker. [eoiSeen or: [stream atEnd]] whileFalse:[self parseNextMarker]. ! ! !FlashJPEGDecoder methodsFor: 'decoding' stamp: 'ar 10/28/2001 16:25'! nextImageDitheredToDepth: depth "Overwritten to yield every now and then." | form xStep yStep x y | ditherMask _ DitherMasks at: depth ifAbsent: [self error: 'can only dither to display depths']. residuals _ WordArray new: 3. sosSeen _ false. self parseFirstMarker. [sosSeen] whileFalse: [self parseNextMarker]. form _ Form extent: (width @ height) depth: depth. xStep _ mcuWidth * DCTSize. yStep _ mcuHeight * DCTSize. y _ 0. 1 to: mcuRowsInScan do: [:row | "self isStreaming ifTrue:[Processor yield]." x _ 0. 1 to: mcusPerRow do: [:col | self decodeMCU. self idctMCU. self colorConvertMCU. mcuImageBuffer displayOn: form at: (x @ y). x _ x + xStep]. y _ y + yStep]. ^ form! ! !FlashLineStyle methodsFor: 'comparing' stamp: 'ar 9/9/2003 22:03'! hash "#hash is re-implemented because #= is re-implemented" ^self color hash bitXor: self width hash! ! !FlashLineStyleTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! setUp super setUp. prototypes add: (FlashLineStyle color: 1 width: 1); add: (FlashLineStyle color: 1 width: 2); add: (FlashLineStyle color: 2 width: 1); add: (FlashLineStyle color: 2 width: 2) ! ! !FlashMorph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:58'! copyExtension "Copy my extensions dictionary" | copiedExtension | self hasExtension ifFalse: [^ self]. copiedExtension _ self extension copy. copiedExtension removeOtherProperties. self extension otherProperties ifNotNil: [self extension otherProperties associationsDo: [:assoc | copiedExtension setProperty: assoc key toValue: assoc value copy]]. self privateExtension: copiedExtension! ! !FlashMorph methodsFor: 'copying' stamp: 'dgd 2/22/2003 14:24'! duplicate "Usually, FlashMorphs exist in a player. If they're grabbed and moved outside the player they should keep their position." | dup player | dup := super duplicate. player := self flashPlayer. dup transform: (self transformFrom: self world). "If extracted from player and no default AA level is set use prefs" (player notNil and: [self defaultAALevel isNil]) ifTrue: [Preferences extractFlashInHighQuality ifTrue: [dup defaultAALevel: 2]. Preferences extractFlashInHighestQuality ifTrue: [dup defaultAALevel: 4]]. ^dup! ! !FlashMorph methodsFor: 'drawing' stamp: 'ar 5/6/2001 19:03'! fullDrawOn: aCanvas | myCanvas | aCanvas isBalloonCanvas ifTrue:[^super fullDrawOn: aCanvas]. myCanvas _ aCanvas asBalloonCanvas. myCanvas deferred: true. super fullDrawOn: myCanvas. myCanvas flush.! ! !FlashMorph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:24'! aboutToBeGrabbedBy: aHand "Usually, FlashMorphs exist in a player. If they're grabbed and moved outside the player they should keep their position." | player | super aboutToBeGrabbedBy: aHand. player := self flashPlayer. player ifNotNil: [player noticeRemovalOf: self]. self transform: (self transformFrom: self world). "If extracted from player and no default AA level is set use prefs" (player notNil and: [self defaultAALevel isNil]) ifTrue: [Preferences extractFlashInHighQuality ifTrue: [self defaultAALevel: 2]. Preferences extractFlashInHighestQuality ifTrue: [self defaultAALevel: 4]]. ^self "Grab me"! ! !FlashMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addUpdating: #getSmoothingLevel action: #nextSmoothingLevel. aCustomMenu add:'show compressed size' translated action: #showCompressedSize.! ! !FlashMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'! getSmoothingLevel "Menu support" | aaLevel | aaLevel := self defaultAALevel ifNil: [1]. aaLevel = 1 ifTrue: [^ 'turn on smoothing' translated]. aaLevel = 2 ifTrue: [^ 'more smoothing' translated]. aaLevel = 4 ifTrue: [^ 'turn off smoothing' translated]! ! !FlashMorph methodsFor: 'menu' stamp: 'gm 2/28/2003 00:16'! showCompressedSize | size string | size := self originalFileSize. string := size = 0 ifTrue: ['Compressed size: not available'] ifFalse: ['Compressed size: ' , size asStringWithCommas , ' bytes']. self world primaryHand attachMorph: ((TextMorph new) contents: string; beAllFont: ScriptingSystem fontForTiles)! ! !FlashMorphReader methodsFor: 'defining text' stamp: 'tk 2/15/2001 16:34'! recordNextChar: glyphIndex advanceWidth: advance | shape transform | (activeFont includesKey: glyphIndex) ifTrue:[ shape _ (activeFont at: glyphIndex) veryDeepCopy reset. "Must include the textMorph's transform here - it might be animated" transform _ ((MatrixTransform2x3 withOffset: textOffset) setScale: (textHeight@textHeight) / 1024.0). transform _ transform composedWithGlobal: textMorph transform. shape transform: transform. shape color: textMorph color. textMorph addMorphBack: shape.]. textOffset _ textOffset + (advance@0).! ! !FlashMorphReader methodsFor: 'private' stamp: 'tk 2/15/2001 16:33'! newMorphFromShape: objectIndex "Return a new character morph from the given object index. If the character morph at objectIndex is already used, then create and return a full copy of it" | prototype | prototype _ self oldMorphFromShape: objectIndex. prototype isNil ifTrue:[^nil]. ^(prototype owner notNil) ifTrue:[prototype veryDeepCopy] ifFalse:[prototype].! ! !FlashMorphReader methodsFor: 'defining buttons' stamp: 'tk 2/16/2001 11:30'! recordButton: buttonId character: characterId state: state layer: layer matrix: matrix colorTransform: cxForm | button children shape | button _ buttons at: buttonId ifAbsent:[^self error: 'button missing']. button id: buttonId. shape _ self oldMorphFromShape: characterId. shape isNil ifTrue:[^nil]. children _ shape submorphs collect:[:m| m veryDeepCopy]. shape _ FlashMorph withAll: children. shape lockChildren. shape depth: layer. shape transform: matrix. shape colorTransform: cxForm. (state anyMask: 1) ifTrue:[ button defaultLook: shape. ]. (state anyMask: 2) ifTrue:[ button overLook: shape. ]. (state anyMask: 4) ifTrue:[ button pressLook: shape. ]. (state anyMask: 8) ifTrue:[ button sensitiveLook: shape. ]. button lockChildren.! ! !FlashMorphReader class methodsFor: 'class initialization' stamp: 'hg 8/1/2000 20:07'! initialize FileList registerFileReader: self! ! !FlashMorphReader class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sd 2/6/2002 21:35'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'swf') | (suffix = '*') ifTrue: [ self services] ifFalse: [#()] ! ! !FlashMorphReader class methodsFor: 'read Flash file' stamp: 'hg 8/3/2000 16:04'! openAsFlash: fullFileName "Open a MoviePlayerMorph on the file (must be in .movie format)." | f player | f _ (FileStream readOnlyFileNamed: fullFileName) binary. player _ (FlashMorphReader on: f) processFile. player startPlaying. player open. ! ! !FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sw 2/17/2002 02:42'! serviceOpenAsFlash "Answer a service for opening a flash file" ^ SimpleServiceEntry provider: self label: 'open as Flash' selector: #openAsFlash: description: 'open file as flash' buttonLabel: 'open'! ! !FlashMorphReader class methodsFor: 'read Flash file' stamp: 'sd 2/1/2002 22:09'! services ^ Array with: self serviceOpenAsFlash! ! !FlashMorphingMorph methodsFor: 'copying' stamp: 'dgd 2/21/2003 23:04'! updateReferencesUsing: aDictionary | srcMorph dstMorph | super updateReferencesUsing: aDictionary. srcMorph := submorphs at: submorphs size - 1. dstMorph := submorphs last. self removeAllMorphs. self from: srcMorph to: dstMorph! ! !FlashPlayerMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 23:40'! loadedFrames: aNumber self isStreaming ifTrue: [activationKeys _ self collectActivationKeys: aNumber. aNumber = 1 ifTrue: [activeMorphs addAll: activationKeys first. self changed]. progressValue contents: aNumber asFloat / maxFrames. "Give others a chance" Smalltalk isMorphic ifTrue: [World doOneCycle] ifFalse: [Processor yield]]. loadedFrames _ aNumber! ! !FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'nk 1/6/2004 12:36'! asWearableCostumeOfExtent: extent "Return a wearable costume for some player" | image oldExtent | oldExtent _ self extent. self extent: extent. image _ self imageForm. self extent: oldExtent. image mapColor: self color to: Color transparent. ^(World drawingClass withForm: image) copyCostumeStateFrom: self! ! !FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'mir 6/12/2001 12:07'! cursor ^self frameNumber ! ! !FlashPlayerMorph methodsFor: 'e-toy support' stamp: 'mir 6/12/2001 12:08'! cursor: aNumber "for backward compatibility" self cursorWrapped: aNumber! ! !FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 15:05'! cursorWrapped: aNumber "Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed." | nextFrame | nextFrame _ aNumber truncated abs. nextFrame >= self maxFrames ifTrue: [nextFrame _ 1]. self stepToFrame: nextFrame! ! !FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:30'! numberAtCursor "Answer the number represented by the object at my current cursor position" ^0! ! !FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:32'! selectedRect "Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph." self transform localBoundsToGlobal: self localBounds! ! !FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:32'! valueAtCursor "Answer the submorph of mine indexed by the value of my 'cursor' slot" ^self! ! !FlashPlayerMorph methodsFor: 'holder' stamp: 'mir 6/12/2001 12:33'! valueAtCursor: aMorph self shouldNotImplement! ! !FlashPlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !FlashPlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'! initialize "initialize the state of the receiver" super initialize. "" self loopFrames: true. localBounds _ bounds. activationKeys _ #(). activeMorphs _ SortedCollection new: 50. activeMorphs sortBlock: [:m1 :m2 | m1 depth > m2 depth]. progressValue _ ValueHolder new. progressValue contents: 0.0. self defaultAALevel: 2. self deferred: true! ! !FlashPlayerMorph methodsFor: 'initialize' stamp: 'tk 2/19/2001 17:47'! makeControls | bb r loopSwitch | r _ AlignmentMorph newRow. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Rewind'; actionSelector: #rewind). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Play'; actionSelector: #startPlaying). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Pause'; actionSelector: #stopPlaying). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Next'; actionSelector: #stepForward). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Prev'; actionSelector: #stepBackward). loopSwitch _ SimpleSwitchMorph new borderWidth: 2; label: 'Loop'; actionSelector: #loopFrames:; target: self; setSwitchState: self loopFrames. r addMorphBack: loopSwitch. loopSwitch _ SimpleSwitchMorph new borderWidth: 2; label: 'Defer'; actionSelector: #toggleDeferred; target: self; setSwitchState: self deferred. r addMorphBack: loopSwitch. bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Fastest'; actionSelector: #drawFastest). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Medium'; actionSelector: #drawMedium). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: 'Nicest'; actionSelector: #drawNicest). bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r addMorphBack: (bb label: '+10'; actionSelector: #jump10). ^ self world activeHand attachMorph: r! ! !FlashPlayerMorph methodsFor: 'initialize' stamp: 'dgd 9/20/2003 16:42'! openInMVC | window extent | self localBounds: localBounds. extent _ bounds extent. window _ FlashPlayerWindow labelled:'Flash Player' translated. window model: (FlashPlayerModel player: self). window addMorph: self frame:(0@0 corner: 1@1). window openInMVCExtent: extent! ! !FlashPlayerMorph methodsFor: 'initialize' stamp: 'dgd 9/20/2003 16:42'! openInWorld | window extent | self localBounds: localBounds. extent _ bounds extent. window _ FlashPlayerWindow labelled:'Flash Player' translated. window model: (FlashPlayerModel player: self). window addMorph: self frame:(0@0 corner: 1@1). window openInWorldExtent: extent! ! !FlashPlayerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:42'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'open sorter' translated action: #openSorter. aCustomMenu add: 'make controls' translated action: #makeControls. aCustomMenu addLine.! ! !FlashPlayerMorph methodsFor: 'player' stamp: 'mir 6/13/2001 14:45'! shouldRememberCostumes ^false! ! !FlashPlayerMorph methodsFor: 'project transition' stamp: 'ar 8/10/2003 18:17'! playProjectTransitionFrom: oldProject to: newProject entering: aBoolean "Play the transition from the old to the new project." Smalltalk isMorphic ifFalse: [^ self]. "Not in MVC" self stopPlaying. owner ifNotNil:[ self stopStepping. owner removeMorph: self]. aBoolean ifTrue:[ self updateProjectFillsFrom: newProject. ] ifFalse:[ self updateProjectFillsFrom: oldProject. self setProperty: #transitionBackground toValue: newProject imageForm. ]. self frameNumber: 1. self loopFrames: false. (self valueOfProperty: #fullScreenTransition ifAbsent:[false]) ifTrue:[self bounds: self world bounds]. self comeToFront. self startStepping. self startPlaying. [playing] whileTrue: [World doOneCycleNow]. self stopPlaying. self stopStepping. owner removeMorph: self. self removeProperty: #transitionBackground. Display deferUpdates: true. ActiveWorld fullDrawOn: (Display getCanvas). Display deferUpdates: false.! ! !FlashPlayerMorph methodsFor: 'stepping' stamp: 'ar 5/24/2001 16:50'! stepToFrame: frame | fullRect postDamage | frame = frameNumber ifTrue:[^self]. frame > loadedFrames ifTrue:[^self]. postDamage _ damageRecorder isNil. postDamage ifTrue:[damageRecorder _ FlashDamageRecorder new]. frame = (frameNumber+1) ifTrue:[ self stepToFrameForward: frame. ] ifFalse:[ activeMorphs _ activeMorphs select:[:any| false]. submorphs do:[:m| (m isFlashMorph and:[m isFlashCharacter]) ifTrue:[ m stepToFrame: frame. m visible ifTrue:[activeMorphs add: m]. ]]. ]. frameNumber _ frame. playing ifTrue:[ self playSoundsAt: frame. self executeActionsAt: frame. ]. (postDamage and:[owner notNil]) ifTrue:[ damageRecorder updateIsNeeded ifTrue:[ fullRect _ damageRecorder fullDamageRect: self localBounds. fullRect _ (self transform localBoundsToGlobal: fullRect). owner invalidRect: (fullRect insetBy: -1) from: self. ]. ]. postDamage ifTrue:[damageRecorder _ nil].! ! !FlashPlayerMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:37'! privateFullMoveBy: delta self handleBoundsChange:[super privateMoveBy: delta]! ! !FlashPlayerMorph class methodsFor: 'scripting' stamp: 'sw 9/26/2001 03:56'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ # ( (collections ( (slot cursor 'The index of the chosen element' Number readWrite player getCursor player setCursorWrapped:) (slot playerAtCursor 'the object currently at the cursor' Player readWrite player getValueAtCursor unused unused) (slot firstElement 'The first object in my contents' Player readWrite player getFirstElement player setFirstElement:) (slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly player getGraphicAtCursor unused unused) )) ) ! ! !FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'dgd 5/1/2003 21:05'! addProgressIndicator progress := ProgressBarMorph new. progress borderWidth: 1. progress color: Color transparent. progress progressColor: Color gray. progress extent: 100 @ (startButton extent y - 6). self addMorph: progress! ! !FlashPlayerWindow methodsFor: 'as yet unclassified' stamp: 'dgd 5/1/2003 21:05'! addProgressIndicator: aValueHolder progress := ProgressBarMorph new. progress borderWidth: 1. progress color: Color transparent. progress progressColor: Color gray. progress value: aValueHolder. progress extent: 100 @ (startButton extent y - 6). self addMorph: progress! ! !FlashPlayerWindow methodsFor: 'initialization' stamp: 'dgd 9/20/2003 16:43'! initialize | aFont | super initialize. aFont _ Preferences standardButtonFont. self addMorph: (startButton _ SimpleButtonMorph new borderWidth: 0; label: 'play' translated font: aFont; color: Color transparent; actionSelector: #startPlaying; target: self). startButton setBalloonText: 'continue playing' translated. self addMorph: (stopButton _ SimpleButtonMorph new borderWidth: 0; label: 'stop' translated font: aFont; color: Color transparent; actionSelector: #stopPlaying; target: self). stopButton setBalloonText: 'stop playing' translated. startButton submorphs first color: Color blue. stopButton submorphs first color: Color red. self adjustBookControls! ! !FlashSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !FlashSorterMorph methodsFor: 'initialization' stamp: 'tk 2/19/2001 17:48'! makeControls | bb r | bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2. r _ AlignmentMorph newRow. r hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 2. r addMorphBack: (bb label: 'Make movie'; actionSelector: #makeMovie). ^r! ! !FlashSpriteMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'! initialize "initialize the state of the receiver" super initialize. "" playing _ false. loadedFrames _ 0. maxFrames _ 1. frameNumber _ 1. sounds _ Dictionary new. actions _ Dictionary new. labels _ Dictionary new. stepTime _ 1. useTimeSync _ true! ! !FlashSpriteMorph methodsFor: 'stepping' stamp: 'ar 5/24/2001 16:50'! stepToFrame: frame "Step to the given frame" | fullRect postDamage lastVisible resortNeeded | frame = frameNumber ifTrue:[^self]. frame > loadedFrames ifTrue:[^self]. postDamage _ damageRecorder isNil. postDamage ifTrue:[damageRecorder _ FlashDamageRecorder new]. lastVisible _ nil. resortNeeded _ false. submorphs do:[:m| (m isFlashMorph and:[m isFlashCharacter]) ifTrue:[ m stepToFrame: frame. m visible ifTrue:[ (lastVisible notNil and:[lastVisible depth < m depth]) ifTrue:[resortNeeded _ true]. lastVisible _ m. (bounds containsRect: m bounds) ifFalse:[bounds _ bounds merge: m bounds]. ]. ]. ]. resortNeeded ifTrue:[submorphs _ submorphs sortBy:[:m1 :m2| m1 depth > m2 depth]]. frameNumber _ frame. playing ifTrue:[ self playSoundsAt: frame. self executeActionsAt: frame. ]. (postDamage and:[owner notNil]) ifTrue:[ damageRecorder updateIsNeeded ifTrue:[ "fullRect _ damageRecorder fullDamageRect. fullRect _ (self transform localBoundsToGlobal: fullRect)." fullRect _ bounds. owner invalidRect: (fullRect insetBy: -1) from: self. ]. ]. postDamage ifTrue:[ damageRecorder _ nil].! ! !FlashThumbnailMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42'! player "answer the receiver's player" ^ player! ! !FlashThumbnailMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 13:29'! drawOn: aCanvas (player isNil or: [frameNumber isNil]) ifTrue: [^super drawOn: aCanvas]. false ifTrue: [super drawOn: aCanvas. ^aCanvas drawString: frameNumber printString in: self innerBounds font: nil color: Color red]. image ifNil: [Cursor wait showWhile: [image := player imageFormOfSize: self extent - (self borderWidth * 2) forFrame: frameNumber. frameNumber printString displayOn: image]]. aCanvas frameRectangle: self bounds width: self borderWidth color: self borderColor. aCanvas paintImage: image at: self topLeft + self borderWidth! ! !Flasher methodsFor: 'operations' stamp: 'sw 5/28/2002 18:44'! onColor "Answer my onColor" ^ onColor ifNil: [onColor _ Color red]! ! !Flasher methodsFor: 'operations' stamp: 'sd 4/21/2002 09:55'! onColor: aColor "Change my on color to be aColor" onColor := aColor. self color: aColor! ! !Flasher methodsFor: 'parts bin' stamp: 'sd 4/21/2002 09:36'! initializeToStandAlone "Initialize the flasher." super initializeToStandAlone. self color: Color red. self onColor: Color red. self borderWidth: 2. self extent: 25@25! ! !Flasher methodsFor: 'stepping and presenter' stamp: 'sw 5/28/2002 18:45'! step "Perform my standard periodic action" super step. self color = self onColor ifTrue: [self color: (onColor alphaMixed: 0.5 with: Color black)] ifFalse: [self color: onColor]! ! !Flasher methodsFor: 'testing' stamp: 'sw 4/17/2002 12:05'! stepTime "Answer the desired time between steps, in milliseconds." ^ 500! ! !Flasher commentStamp: '' prior: 0! A simple example - a circle that flashes. The "onColor" instance variable indicates the color to use when "on", A darker color is used to represent "off". The #step method, called every 500ms. by default, alternatively makes the flasher show its "on" and its "off" color.! !Flasher class methodsFor: 'parts bin' stamp: 'sw 4/17/2002 11:37'! descriptionForPartsBin "Answer a description of the receiver for use in a parts bin" ^ self partName: 'Flasher' categories: #('Demo') documentation: 'A circle that flashes'! ! !FlexMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:44'! addCustomMenuItems: aCustomMenu hand: aHandMorph "super addCustomMenuItems: aCustomMenu hand: aHandMorph." aCustomMenu addLine. aCustomMenu add: 'update from original' translated action: #updateFromOriginal. aCustomMenu addList: { {'border color...' translated. #changeBorderColor:}. {'border width...' translated. #changeBorderWidth:}. }. aCustomMenu addLine. ! ! !FlexibleVocabulariesInfo commentStamp: 'nk 3/11/2004 16:38' prior: 0! Package: FlexibleVocabularies-nk Date: 12 October 2003 Author: Ned Konz This makes it possible for packages to extend Morph class vocabularies. Previously, you'd have to edit #additionsToViewerCategories, which would result in potential conflicts between different packages that all wanted to (for instance) extend Morph's vocabulary. Subclasses that have additions can do one or both of: - override #additionsToViewerCategories (as before) - define one or more additionToViewerCategory* methods. The advantage of the latter technique is that class extensions may be added by external packages without having to re-define additionsToViewerCategories. So, for instance, package A could add a method named #additionsToViewerCategoryPackageABasic and its methods would be added to the vocabulary automatically. NOTE: this change set is hand-rearranged to avoid problems on file-in. Specifically, Morph>>hasAdditionsToViewerCategories must come before Morph class>>additionsToViewerCategories ! !FlexibleVocabulariesInfo class methodsFor: 'class initialization' stamp: 'nk 5/3/2004 15:48'! initialize [self new register] on: MessageNotUnderstood do: []. SyntaxMorph class removeSelector: #initialize. SyntaxMorph removeSelector: #allSpecs. EToyVocabulary removeSelector: #morphClassesDeclaringViewerAdditions. SyntaxMorph clearAllSpecs. Vocabulary initialize. ! ! !Float methodsFor: 'arithmetic' stamp: 'hh 10/3/2000 11:46'! / aNumber "Primitive. Answer the result of dividing receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber isZero ifTrue: [^(ZeroDivide dividend: self) signal]. ^ aNumber adaptToFloat: self andSend: #/! ! !Float methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'! reciprocal #Numeric. "Changed 200/01/19 For ANSI support." self = 0 ifTrue: ["<- Chg" ^ (ZeroDivide dividend: self) signal"<- Chg"]. "<- Chg" ^ 1.0 / self! ! !Float methodsFor: 'mathematical functions' stamp: 'AFi 11/23/2002 21:06'! raisedTo: aNumber "Answer the receiver raised to aNumber." aNumber isInteger ifTrue: ["Do the special case of integer power" ^ self raisedToInteger: aNumber]. self < 0.0 ifTrue: [ ArithmeticError signal: ' raised to a non-integer power' ]. 0.0 = aNumber ifTrue: [^ 1.0]. "special case for exponent = 0.0" (self= 0.0) | (aNumber = 1.0) ifTrue: [^ self]. "special case for self = 1.0" ^ (self ln * aNumber asFloat) exp "otherwise use logarithms" ! ! !Float methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'! sqrt "Answer the square root of the receiver. Optional. See Object documentation whatIsAPrimitive." | exp guess eps delta | #Numeric. "Changed 200/01/19 For ANSI support." "Newton-Raphson" self <= 0.0 ifTrue: [self = 0.0 ifTrue: [^ 0.0] ifFalse: ["v Chg" ^ FloatingPointException signal: 'undefined if less than zero.']]. "first guess is half the exponent" exp := self exponent // 2. guess := self timesTwoPower: 0 - exp. "get eps value" eps := guess * Epsilon. eps := eps * eps. delta := self - (guess * guess) / (guess * 2.0). [delta * delta > eps] whileTrue: [guess := guess + delta. delta := self - (guess * guess) / (guess * 2.0)]. ^ guess! ! !Float methodsFor: 'converting' stamp: 'mk 10/27/2003 18:16'! adaptToComplex: rcvr andSend: selector "If I am involved in arithmetic with a Complex number, convert me to a Complex number." ^ rcvr perform: selector with: self asComplex! ! !Float methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector "Convert receiverScaledDecimal to a Float and do the arithmetic. receiverScaledDecimal arithmeticOpSelector self." #Numeric. "add 200/01/19 For ScaledDecimal support." ^ receiverScaledDecimal asFloat perform: arithmeticOpSelector with: self! ! !Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:17'! asApproximateFraction "Answer a Fraction approximating the receiver. This conversion uses the continued fraction method to approximate a floating point number." ^ self asApproximateFractionAtOrder: 0! ! !Float methodsFor: 'converting' stamp: 'st 9/17/2004 17:14'! asApproximateFractionAtOrder: maxOrder "Answer a Fraction approximating the receiver. This conversion uses the continued fraction method to approximate a floating point number. If maxOrder is zero, use maximum order" | num1 denom1 num2 denom2 int frac newD temp order | num1 := self asInteger. "The first of two alternating numerators" denom1 := 1. "The first of two alternating denominators" num2 := 1. "The second numerator" denom2 := 0. "The second denominator--will update" int := num1. "The integer part of self" frac := self fractionPart. "The fractional part of self" order := maxOrder = 0 ifTrue: [-1] ifFalse: [maxOrder]. [frac = 0 or: [order = 0] ] whileFalse: ["repeat while the fractional part is not zero and max order is not reached" order _ order - 1. newD := 1.0 / frac. "Take reciprocal of the fractional part" int := newD asInteger. "get the integer part of this" frac := newD fractionPart. "and save the fractional part for next time" temp := num2. "Get old numerator and save it" num2 := num1. "Set second numerator to first" num1 := num1 * int + temp. "Update first numerator" temp := denom2. "Get old denominator and save it" denom2 := denom1. "Set second denominator to first" denom1 := int * denom1 + temp. "Update first denominator" 10000000000.0 < denom1 ifTrue: ["Is ratio past float precision? If so, pick which of the two ratios to use" num2 = 0.0 ifTrue: ["Is second denominator 0?" ^ Fraction numerator: num1 denominator: denom1]. ^ Fraction numerator: num2 denominator: denom2]]. "If fractional part is zero, return the first ratio" denom1 = 1 ifTrue: ["Am I really an Integer?" ^ num1 "Yes, return Integer result"] ifFalse: ["Otherwise return Fraction result" ^ Fraction numerator: num1 denominator: denom1]! ! !Float methodsFor: 'converting' stamp: 'mk 10/27/2003 17:46'! asComplex "Answer a Complex number that represents value of the the receiver." ^ Complex real: self imaginary: 0! ! !Float methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! printPaddedWith: aCharacter to: aNumber "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least on aNumber integerPart characters and padded the right with aCharacter to be at least anInteger fractionPart characters." | aStream digits fPadding fLen iPadding iLen curLen periodIndex | #Numeric. "2000/03/04 Harmon R. Added Date and Time support" aStream := WriteStream on: (String new: 10). self printOn: aStream. digits := aStream contents. periodIndex := digits indexOf: $.. curLen := periodIndex - 1. iLen := aNumber integerPart. curLen < iLen ifTrue: [iPadding := (String new: (iLen - curLen) asInteger) atAllPut: aCharacter; yourself] ifFalse: [iPadding := '']. curLen := digits size - periodIndex. fLen := (aNumber fractionPart * (aNumber asFloat exponent * 10)) asInteger. curLen < fLen ifTrue: [fPadding := (String new: fLen - curLen) atAllPut: aCharacter; yourself] ifFalse: [fPadding := '']. ^ iPadding , digits , fPadding! ! !Float class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'! one #Numeric. "add 200/01/19 For protocol support." ^ 1.0! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/7/2001 23:07'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a Number. If possible, convert it to a float and perform the (more efficient) primitive operation." selector == #+ ifTrue:[^self + rcvr]. selector == #* ifTrue:[^self * rcvr]. selector == #- ifTrue:[^self negated += rcvr]. selector == #/ ifTrue:[^self * (1.0 / rcvr)]. ^super adaptToNumber: rcvr andSend: selector! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/7/2001 23:04'! negated ^self clone *= -1! ! !FloatArray methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'! hash | result | result _ 0. 1 to: self size do:[:i| result _ result + (self basicAt: i) ]. ^result bitAnd: 16r1FFFFFFF! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'! sum ^ super sum! ! !FloatArray methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:18'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^OrderedCollectionInspector! ! !FloatTest methodsFor: 'testing - arithmetic' stamp: 'st 9/20/2004 17:04'! testContinuedFractions self assert: (Float pi asApproximateFractionAtOrder: 1) = (22/7). self assert: (Float pi asApproximateFractionAtOrder: 3) = (355/113)! ! !FloatTest methodsFor: 'testing - arithmetic' stamp: 'fbs 3/8/2004 22:10'! testDivide self assert: 2.0 / 1 = 2. self should: [ 2.0 / 0 ] raise: ZeroDivide.! ! !FloatTest methodsFor: 'infinity behavior' stamp: 'BG 9/14/2004 19:07'! testInfinity1 "FloatTest new testInfinity1" | i1 i2 | i1 := 10000 exp. i2 := 1000000000 exp. self assert: i1 isInfinite & i2 isInfinite & (i1 = i2). " All infinities are equal. (This is a very substantial difference to NaN's, which are never equal. " ! ! !FloatTest methodsFor: 'infinity behavior' stamp: 'BG 9/14/2004 19:10'! testInfinity2 "FloatTest new testInfinity2" | i1 i2 | i1 := 10000 exp. i2 := 1000000000 exp. i2 := 0 - i2. " this is entirely ok. You can compute with infinite values. " self assert: i1 isInfinite & i2 isInfinite & i1 positive & i2 negative. self deny: i1 = i2. " All infinities are signed. Negative infinity is not equal to Infinity " ! ! !FloatTest methodsFor: 'NaN behavior' stamp: 'BG 9/14/2004 18:53'! testNaN1 "FloatTest new testNaN1" self assert: Float nan == Float nan. self deny: Float nan = Float nan. " a NaN is not equal to itself. " ! ! !FloatTest methodsFor: 'NaN behavior' stamp: 'dtl 10/1/2004 18:26'! testNaN2 "Two NaN values are always considered to be different. On an little-endian machine (32 bit Intel), Float nan is 16rFFF80000 16r00000000. On a big-endian machine (PowerPC), Float nan is 16r7FF80000 16r00000000. Changing the bit pattern of the first word of a NaN produces another value that is still considered equal to NaN. This test should work on both little endian and big endian machines. However, it is not guaranteed to work on future 64 bit versions of Squeak, for which Float may have different internal representations." "FloatTest new testNaN2" | nan1 nan2 | nan1 := Float nan copy. nan2 := Float nan copy. "test two instances of NaN with the same bit pattern" self deny: nan1 = nan2. self deny: nan1 == nan2. self deny: nan1 = nan1. self assert: nan1 == nan1. "change the bit pattern of nan1" self assert: nan1 size == 2. self assert: (nan1 at: 2) = 0. nan1 at: 1 put: (nan1 at: 1) + 999. self assert: nan1 isNaN. self assert: nan2 isNaN. self deny: (nan1 at: 1) = (nan2 at: 1). "test two instances of NaN with different bit patterns" self deny: nan1 = nan2. self deny: nan1 == nan2. self deny: nan1 = nan1. self assert: nan1 == nan1 ! ! !FloatTest methodsFor: 'NaN behavior' stamp: 'BG 9/14/2004 18:57'! testNaN3 "FloatTest new testNaN3" | set item identitySet | set := Set new. set add: (item := Float nan). self deny: (set includes: item). identitySet := IdentitySet new. identitySet add: (item := Float nan). self assert: (identitySet includes: item). " as a NaN is not equal to itself, it can not be retrieved from a set " ! ! !FloatTest methodsFor: 'NaN behavior' stamp: 'BG 9/14/2004 18:54'! testNaN4 "FloatTest new testNaN4" | dict | dict := Dictionary new. dict at: Float nan put: #NaN. self deny: (dict includes: Float nan). " as a NaN is not equal to itself, it can not be retrieved when it is used as a dictionary key " ! ! !FloatTest methodsFor: 'zero behavior' stamp: 'md 4/16/2003 15:02'! testIsZero self assert: 0.0 isZero. self deny: 0.1 isZero.! ! !FloatTest methodsFor: 'zero behavior' stamp: 'dtl 9/26/2004 10:19'! testZero1 "FloatTest new testZero1" self assert: Float negativeZero = 0 asFloat. self assert: (Float negativeZero at: 1) ~= (0 asFloat at: 1). " The negative zero has a bit representation that is different from the bit representation of the positive zero. Nevertheless, both values are defined to be equal. " ! ! !FloatTest methodsFor: 'testing - conversion' stamp: 'dtl 9/18/2004 12:40'! testStringAsNumber "This covers parsing in Number>>readFrom:" | aFloat | aFloat _ '10r-12.3456' asNumber. self assert: -12.3456 = aFloat. aFloat _ '10r-12.3456e2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '10r-12.3456d2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '10r-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '12.3456q2' asNumber. self assert: 1234.56 = aFloat. ! ! !FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0! I provide a test suite for Float values. Examine my tests to see how Floats should behave, and see how to use them.! !FloatingBookControlsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !FloatingBookControlsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:16'! initialize "initialize the state of the receiver" super initialize. "" self layoutInset: 0; hResizing: #shrinkWrap; vResizing: #shrinkWrap ! ! !FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 12:48'! fontNamed: fontName fromLiteral: aString "NOTE -- THIS IS AN OBSOLETE METHOD THAT MAY CAUSE ERRORS. The old form of fileOut for FontSets produced binary literal strings which may not be accurately read in systems with support for international character sets. If possible, file the FontSet out again from a system that produces the newer MIME encoding (current def of compileFont:), and uses the corresponding altered version of this method. If this is not easy, then file the fontSet into an older system (3.7 or earlier), assume it is called FontSetZork... execute FontSetZork installAsTextStyle. copy the compileFont: method from this system into that older one. remove the class FontSetZork. Execute: FontSet convertTextStyleNamed: 'Zork', and see that it creates a new FontSetZork. FileOut the new class FontSetZork. The resulting file should be able to be read into this system. " ^ StrikeFont new name: fontName; readFromStrike2Stream: (ReadStream on: aString asByteArray)! ! !FontSet class methodsFor: 'installing' stamp: 'di 1/24/2005 11:13'! fontNamed: fontName fromMimeLiteral: aString "This method allows a font set to be captured as sourcecode in a subclass. The string literals will presumably be created by printing, eg, (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile, and following the logic in compileFont: to encode and add a heading. See the method installAsTextStyle to see how this can be used." ^ StrikeFont new name: fontName; readFromStrike2Stream: (Base64MimeConverter mimeDecodeToBytes: aString readStream)! ! !FontSet class methodsFor: 'installing' stamp: 'nk 8/31/2004 09:23'! size: pointSize fromLiteral: aString "This method allows a font set to be captured as sourcecode in a subclass. The string literals will presumably be created by printing, eg, (FileStream readOnlyFileNamed: 'Palatino24.sf2') contentsOfEntireFile, and then pasting into a browser after a heading like, eg, size24 ^ self size: 24 fromLiteral: '--unreadable binary data--' See the method installAsTextStyle to see how this can be used." "This method is old and for backward compatibility only. please use fontNamed:fromLiteral: instead." self flag: #bob. "used in Alan's projects" ^(StrikeFont new) name: self fontName , (pointSize < 10 ifTrue: ['0' , pointSize printString] ifFalse: [pointSize printString]); readFromStrike2Stream: ((RWBinaryOrTextStream with: aString) reset; binary); yourself! ! !FontSet class methodsFor: 'compiling' stamp: 'di 1/24/2005 12:40'! compileFont: strikeFont | tempName literalString header sizeStr familyName | tempName _ 'FontTemp.sf2'. strikeFont writeAsStrike2named: tempName. literalString _ (Base64MimeConverter mimeEncode: (FileStream readOnlyFileNamed: tempName) binary) contents fullPrintString. sizeStr _ strikeFont pointSize asString. familyName _ strikeFont name first: (strikeFont name findLast: [:x | x isDigit not]). header _ 'size' , sizeStr , ' ^ self fontNamed: ''' , familyName , sizeStr , ''' fromMimeLiteral: ' . self class compile: header , literalString classified: 'fonts' notifying: nil. FileDirectory default deleteFileNamed: tempName ! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:04'! defaultAction familyName ifNil: [ familyName := 'NoName' ]. pixelSize ifNil: [ pixelSize := 12 ]. ^((familyName beginsWith: 'Comic') ifTrue: [ TextStyle named: (Preferences standardEToysFont familyName) ] ifFalse: [ TextStyle default ]) fontOfSize: pixelSize.! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! familyName "Answer the value of familyName" ^ familyName! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! familyName: anObject "Set the value of familyName" familyName _ anObject! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! pixelSize "Answer the value of pixelSize" ^ pixelSize! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! pixelSize: anObject "Set the value of pixelSize" pixelSize _ anObject! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 16:55'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: familyName; nextPut: $-; print: pixelSize; nextPut: $).! ! !FontSubstitutionDuringLoading commentStamp: '' prior: 0! signaled by font loading code when reading a DiskProxy that calls for a missing font.! !FontSubstitutionDuringLoading class methodsFor: 'as yet unclassified' stamp: 'nk 11/8/2004 15:07'! forFamilyName: aName pixelSize: aSize ^(self new) familyName: aName; pixelSize: aSize; yourself.! ! !FontTest methodsFor: 'testing' stamp: 'yo 1/13/2005 16:44'! testDisplay "self debug: #testDisplay" | text font bb destPoint width | text _ 'test' asText. font _ TextStyle default fontOfSize: 21. text addAttribute: (TextFontReference toFont: font). bb _ (Form extent: 100 @ 30) getCanvas privatePort. bb combinationRule: Form paint. font installOn: bb foregroundColor: Color black backgroundColor: Color white. destPoint _ font displayString: text on: bb from: 1 to: 4 at: 0@0 kern: 1. width _ text inject: 0 into: [:max :char | max + (font widthOf: char)]. self assert: destPoint x = (width + 4). "bb destForm asMorph openInHand." ! ! !FontTest methodsFor: 'testing' stamp: 'yo 1/13/2005 16:41'! testFallback "self debug: #testFallback" | text font bb destPoint | text _ (Character value: 257) asString asText. font _ TextStyle default fontOfSize: 21. text addAttribute: (TextFontReference toFont: font). bb _ (Form extent: 100 @ 30) getCanvas privatePort. bb combinationRule: Form paint. font installOn: bb foregroundColor: Color black backgroundColor: Color white. destPoint _ font displayString: text on: bb from: 1 to: 1 at: 0@0 kern: 1. "bb destForm asMorph openInHand." self assert: destPoint x = ((font widthOf: $?) + 1). ! ! !FontTest methodsFor: 'testing' stamp: 'tak 12/22/2004 00:56'! testMultistringFallbackFont "self debug: #testMultistringFallbackFont" | text p style height width | [(TextStyle default fontArray at: JapaneseEnvironment leadingChar) ifNil: [^ self]] ifError: [:err :rcvr | ^ self]. text := ((#(20983874 20983876 20983878 ) collect: [:e | e asCharacter]) as: String) asText. p := MultiNewParagraph new. style := TextStyle new leading: 0; newFontArray: {Preferences standardFlapFont}. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := text inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height). "Display getCanvas paragraph: p bounds: (10 @ 10 extent: 100 @ 100) color: Color black"! ! !FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 18:02'! testMultistringFont "self debug: #testMultistringFont" | text p style height width | [(TextStyle default fontArray at: JapaneseEnvironment leadingChar) ifNil: [^ self]] ifError: [:err :rcvr | ^ self]. text := ((#(20983874 20983876 20983878 ) collect: [:e | e asCharacter]) as: String) asText. p := MultiNewParagraph new. style := TextStyle default. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := text inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height). "Display getCanvas paragraph: p bounds: (10 @ 10 extent: 100 @ 100) color: Color black"! ! !FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 14:50'! testParagraph "self debug: #testParagraph" | text p style height width | text := 'test' asText. p := MultiNewParagraph new. style := TextStyle default. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := text inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height)! ! !FontTest methodsFor: 'testing' stamp: 'tak 12/21/2004 17:19'! testParagraphFallback "self debug: #testParagraphFallback" | text p style height width e expect | e := (Character value: 257) asString. text := ('test' , e , e , e , e , 'test') asText. expect := 'test????test'. p := MultiNewParagraph new. style := TextStyle default. p compose: text style: style from: 1 in: (0 @ 0 corner: 100 @ 100). "See CompositionScanner>>setActualFont: & CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide:" height := style defaultFont height + style leading. width := expect inject: 0 into: [:tally :next | tally + (style defaultFont widthOf: next)]. p adjustRightX. self assert: p extent = (width @ height). "Display getCanvas paragraph: p bounds: (10 @ 10 extent: 100 @ 100) color: Color black"! ! !FontTest methodsFor: 'testing' stamp: 'tak 3/11/2005 16:24'! testResetAfterEmphasized "self debug: #testResetAfterEmphasized" | normal derivative | normal _ TextStyle defaultFont. derivative _ normal emphasized: 3. self assert: (normal derivativeFonts at: 2) == derivative. normal reset. self assert: normal derivativeFonts isEmpty ! ! !FontTest commentStamp: 'tak 3/11/2005 14:31' prior: 0! I am mainly a test for fallback font. FontTest buildSuite run! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:41'! bitsSize | pixPerWord | depth == nil ifTrue: [depth _ 1]. pixPerWord _ 32 // self depth. ^ width + pixPerWord - 1 // pixPerWord * height! ! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:45'! depth ^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! ! !Form methodsFor: 'accessing' stamp: 'ar 5/17/2001 15:50'! nativeDepth "Return the 'native' depth of the receiver, e.g., including the endianess" ^depth! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'! dominantColor | tally max maxi | self depth > 16 ifTrue: [^(self asFormOfDepth: 16) dominantColor]. tally _ self tallyPixelValues. max _ maxi _ 0. tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. ^ Color colorFromPixelValue: maxi - 1 depth: self depth! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:40'! pixelCompare: aRect with: otherForm at: otherLoc "Compare the selected bits of this form (those within aRect) against those in a similar rectangle of otherFrom. Return the sum of the absolute value of the differences of the color values of every pixel. Obviously, this is most useful for rgb (16- or 32-bit) pixels but, in the case of 8-bits or less, this will return the sum of the differing bits of the corresponding pixel values (somewhat less useful)" | pixPerWord temp | pixPerWord _ 32//self depth. (aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue: ["If word-aligned, use on-the-fly difference" ^ (BitBlt current toForm: self) copy: aRect from: otherLoc in: otherForm fillColor: nil rule: 32]. "Otherwise, combine in a word-sized form and then compute difference" temp _ self copy: aRect. temp copy: aRect from: otherLoc in: otherForm rule: 21. ^ (BitBlt current toForm: temp) copy: aRect from: otherLoc in: nil fillColor: (Bitmap with: 0) rule: 32 " Dumb example prints zero only when you move over the original rectangle... | f diff | f _ Form fromUser. [Sensor anyButtonPressed] whileFalse: [diff _ f pixelCompare: f boundingBox with: Display at: Sensor cursorPoint. diff printString , ' ' displayAt: 0@0] "! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:42'! primCountBits "Count the non-zero pixels of this form." self depth > 8 ifTrue: [^(self asFormOfDepth: 8) primCountBits]. ^ (BitBlt current toForm: self) fillColor: (Bitmap with: 0); destRect: (0@0 extent: width@height); combinationRule: 32; copyBits! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:37'! rectangleEnclosingPixelsNotOfColor: aColor "Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background." | cm slice copyBlt countBlt top bottom newH left right | "map the specified color to 1 and all others to 0" cm _ Bitmap new: (1 bitShift: (self depth min: 15)). cm primFill: 1. cm at: (aColor indexInMap: cm) put: 0. "build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest" slice _ Form extent: width@1 depth: 1. copyBlt _ (BitBlt current toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: width height: 1; colorMap: cm. countBlt _ (BitBlt current toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from top and bottom" top _ (0 to: height) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0] ifNone: [^ 0@0 extent: 0@0]. bottom _ (height - 1 to: top by: -1) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0]. "build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest" newH _ bottom - top + 1. slice _ Form extent: 1@newH depth: 1. copyBlt _ (BitBlt current toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: 1 height: newH; colorMap: cm. countBlt _ (BitBlt current toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from left and right" left _ (0 to: width) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. right _ (width - 1 to: left by: -1) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. ^ left@top corner: (right + 1)@(bottom + 1) ! ! !Form methodsFor: 'bordering' stamp: 'ar 5/17/2001 15:42'! borderFormOfWidth: borderWidth sharpCorners: sharpen "Smear this form around and then subtract the original to produce an outline. If sharpen is true, then cause right angles to be outlined by right angles (takes an additional diagonal smears ANDed with both horizontal and vertical smears)." | smearForm bigForm smearPort all cornerForm cornerPort nbrs | self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." bigForm _ self deepCopy. all _ bigForm boundingBox. smearForm _ Form extent: self extent. smearPort _ BitBlt current toForm: smearForm. sharpen ifTrue: [cornerForm _ Form extent: self extent. cornerPort _ BitBlt current toForm: cornerForm]. nbrs _ (0@0) fourNeighbors. 1 to: borderWidth do: [:i | "Iterate to get several layers of 'skin'" nbrs do: [:d | "Smear the self in 4 directions to grow each layer of skin" smearPort copyForm: bigForm to: d rule: Form under]. sharpen ifTrue: ["Special treatment to smear sharp corners" nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do: [:d1 :d2 | "Copy corner points diagonally" cornerPort copyForm: bigForm to: d1+d2 rule: Form over. "But only preserve if there were dots on either side" cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and. cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and. smearPort copyForm: cornerForm to: 0@0 rule: Form under]. ]. bigForm copy: all from: 0@0 in: smearForm rule: Form over. ]. "Now erase the original shape to obtain the outline" bigForm copy: all from: 0@0 in: self rule: Form erase. ^ bigForm! ! !Form methodsFor: 'bordering' stamp: 'di 10/21/2001 09:39'! shapeBorder: aColor width: borderWidth "A simplified version for shapes surrounded by transparency (as SketchMorphs). Note also this returns a new form that may be larger, and does not affect the original." | shapeForm borderForm newForm | newForm _ Form extent: self extent + (borderWidth*2) depth: self depth. newForm fillColor: Color transparent. self displayOn: newForm at: (0@0) + borderWidth. "First identify the shape in question as a B/W form" shapeForm _ (newForm makeBWForm: Color transparent) reverse. "Now find the border of that shape" borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: false. "Finally use that shape as a mask to paint the border with color" ^ newForm fillShape: borderForm fillColor: aColor! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! balancedPatternFor: aColor "Return the pixel word for representing the given color on the receiver" self hasNonStandardPalette ifTrue:[^self bitPatternFor: aColor] ifFalse:[^aColor balancedPatternForDepth: self depth]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! bitPatternFor: aColor "Return the pixel word for representing the given color on the receiver" aColor isColor ifFalse:[^aColor bitPatternForDepth: self depth]. self hasNonStandardPalette ifTrue:[^Bitmap with: (self pixelWordFor: aColor)] ifFalse:[^aColor bitPatternForDepth: self depth]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! colormapFromARGB "Return a ColorMap mapping from canonical ARGB space into the receiver. Note: This version is optimized for Squeak forms." | map nBits | self hasNonStandardPalette ifTrue:[^ColorMap mappingFromARGB: self rgbaBitMasks]. self depth <= 8 ifTrue:[ map _ Color colorMapIfNeededFrom: 32 to: self depth. map size = 512 ifTrue:[nBits _ 3]. map size = 4096 ifTrue:[nBits _ 4]. map size = 32768 ifTrue:[nBits _ 5]. ^ColorMap shifts: (Array with: 3 * nBits - 24 with: 2 * nBits - 16 with: 1 * nBits - 8 with: 0) masks: (Array with: (1 << nBits) - 1 << (24 - nBits) with: (1 << nBits) - 1 << (16 - nBits) with: (1 << nBits) - 1 << (8 - nBits) with: 0) colors: map]. self depth = 16 ifTrue:[ ^ColorMap shifts: #(-9 -6 -3 0) masks: #(16rF80000 16rF800 16rF8 0)]. self depth = 32 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. self error:'Bad depth'! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/16/2001 22:23'! colormapIfNeededFor: destForm "Return a ColorMap mapping from the receiver to destForm." (self hasNonStandardPalette or:[destForm hasNonStandardPalette]) ifTrue:[^self colormapFromARGB mappingTo: destForm colormapFromARGB] ifFalse:[^self colormapIfNeededForDepth: destForm depth]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:42'! colormapIfNeededForDepth: destDepth "Return a colormap for displaying the receiver at the given depth, or nil if no colormap is needed." self depth = destDepth ifTrue: [^ nil]. "not needed if depths are the same" ^ Color colorMapIfNeededFrom: self depth to: destDepth ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! colormapToARGB "Return a ColorMap mapping from the receiver into canonical ARGB space." self hasNonStandardPalette ifTrue:[^self colormapFromARGB inverseMap]. self depth <= 8 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000) colors: (Color colorMapIfNeededFrom: self depth to: 32)]. self depth = 16 ifTrue:[ ^ColorMap shifts: #( 9 6 3 0) masks: #(16r7C00 16r3E0 16r1F 0)]. self depth = 32 ifTrue:[ ^ColorMap shifts: #(0 0 0 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000)]. self error:'Bad depth'! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:38'! mapColor: oldColor to: newColor "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | map _ (Color cachedColormapFrom: self depth to: self depth) copy. map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: self depth). (BitBlt current toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:40'! mapColors: oldColorBitsCollection to: newColorBits "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | self depth < 16 ifTrue: [map _ (Color cachedColormapFrom: self depth to: self depth) copy] ifFalse: [ "use maximum resolution color map" "source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component" map _ Color computeRGBColormapFor: self depth bitsPerColor: 5]. oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits]. (BitBlt current toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'color mapping' stamp: 'ar 12/14/2001 18:11'! maskingMap "Return a color map that maps all colors except transparent to words of all ones. Used to create a mask for a Form whose transparent pixel value is zero." ^Color maskingMap: self depth! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:41'! newColorMap "Return an uninitialized color map array appropriate to this Form's depth." ^ Bitmap new: (1 bitShift: (self depth min: 15)) ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! pixelValueFor: aColor "Return the pixel word for representing the given color on the receiver" self hasNonStandardPalette ifTrue:[^self colormapFromARGB mapPixel: (aColor pixelValueForDepth: 32)] ifFalse:[^aColor pixelValueForDepth: self depth]! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! pixelWordFor: aColor "Return the pixel word for representing the given color on the receiver" | basicPattern | self hasNonStandardPalette ifFalse:[^aColor pixelWordForDepth: self depth]. basicPattern _ self pixelValueFor: aColor. self depth = 32 ifTrue:[^basicPattern] ifFalse:[^aColor pixelWordFor: self depth filledWith: basicPattern]! ! !Form methodsFor: 'color mapping' stamp: 'di 10/16/2001 15:23'! reducedPaletteOfSize: nColors "Return an array of colors of size nColors, such that those colors represent well the pixel values actually found in this form." | threshold tallies colorTallies dist delta palette cts top cluster | tallies _ self tallyPixelValues. "An array of tallies for each pixel value" threshold _ width * height // 500. "Make an array of (color -> tally) for all tallies over threshold" colorTallies _ Array streamContents: [:s | tallies withIndexDo: [:v :i | v >= threshold ifTrue: [s nextPut: (Color colorFromPixelValue: i-1 depth: depth) -> v]]]. "Extract a set of clusters by picking the top tally, and then removing all others whose color is within dist of it. Iterate the process, adjusting dist until we get nColors." dist _ 0.2. delta _ dist / 2. [cts _ colorTallies copy. palette _ Array streamContents: [:s | [cts isEmpty] whileFalse: [top _ cts detectMax: [:a | a value]. cluster _ cts select: [:a | (a key diff: top key) < dist]. s nextPut: top key -> (cluster detectSum: [:a | a value]). cts _ cts copyWithoutAll: cluster]]. palette size = nColors or: [delta < 0.001]] whileFalse: [palette size > nColors ifTrue: [dist _ dist + delta] ifFalse: [dist _ dist - delta]. delta _ delta / 2]. ^ palette collect: [:a | a key] ! ! !Form methodsFor: 'converting' stamp: 'ar 6/16/2002 17:44'! asFormOfDepth: d | newForm | d = self depth ifTrue:[^self]. newForm _ Form extent: self extent depth: d. (BitBlt current toForm: newForm) colorMap: (self colormapIfNeededFor: newForm); copy: (self boundingBox) from: 0@0 in: self fillColor: nil rule: Form over. ^newForm! ! !Form methodsFor: 'converting' stamp: 'ar 5/17/2001 15:39'! asGrayScale "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)" | f32 srcForm result map bb grays | self depth = 32 ifFalse: [ f32 _ Form extent: width@height depth: 32. self displayOn: f32. ^ f32 asGrayScale]. self unhibernate. srcForm _ Form extent: (width * 4)@height depth: 8. srcForm bits: bits. result _ ColorForm extent: width@height depth: 8. map _ Bitmap new: 256. 2 to: 256 do: [:i | map at: i put: i - 1]. map at: 1 put: 1. "map zero pixel values to near-black" bb _ (BitBlt current toForm: result) sourceForm: srcForm; combinationRule: Form over; colorMap: map. 0 to: width - 1 do: [:dstX | bb sourceRect: (((dstX * 4) + 2)@0 extent: 1@height); destOrigin: dstX@0; copyBits]. "final BitBlt to zero-out pixels that were truely transparent in the original" map _ Bitmap new: 512. map at: 1 put: 16rFF. (BitBlt current toForm: result) sourceForm: self; sourceRect: self boundingBox; destOrigin: 0@0; combinationRule: Form erase; colorMap: map; copyBits. grays _ (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0]. grays at: 1 put: Color transparent. result colors: grays. ^ result ! ! !Form methodsFor: 'converting' stamp: 'di 10/16/2001 19:23'! copyWithColorsReducedTo: nColors "Note: this has not been engineered. There are better solutions in the literature." | palette colorMap pc closest | palette _ self reducedPaletteOfSize: nColors. colorMap _ (1 to: (1 bitShift: depth)) collect: [:i | pc _ Color colorFromPixelValue: i-1 depth: depth. closest _ palette detectMin: [:c | c diff: pc]. closest pixelValueForDepth: depth]. ^ self deepCopy copyBits: self boundingBox from: self at: 0@0 colorMap: (colorMap as: Bitmap) ! ! !Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:13'! displayInterpolatedIn: aRectangle on: aForm "Display the receiver on aForm, using interpolation if necessary. Form fromUser displayInterpolatedOn: Display. Note: When scaling we attempt to use bilinear interpolation based on the 3D engine. If the engine is not there then we use WarpBlt. " | engine adjustedR | self extent = aRectangle extent ifTrue:[^self displayOn: aForm at: aRectangle origin]. Smalltalk at: #B3DRenderEngine ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)]. engine ifNil:[ "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aRectangle; combinationRule: 3; cellSize: 2; warpBits. ^self ]. "Otherwise use the 3D engine for our purposes" "there seems to be a slight bug in B3D which the following adjusts for" adjustedR _ (aRectangle withRight: aRectangle right + 1) translateBy: 0@1. engine viewport: adjustedR. engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). engine texture: self. engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). engine finish.! ! !Form methodsFor: 'displaying' stamp: 'ar 2/13/2001 22:12'! displayInterpolatedOn: aForm "Display the receiver on aForm, using interpolation if necessary. Form fromUser displayInterpolatedOn: Display. Note: When scaling we attempt to use bilinear interpolation based on the 3D engine. If the engine is not there then we use WarpBlt. " | engine | self extent = aForm extent ifTrue:[^self displayOn: aForm]. Smalltalk at: #B3DRenderEngine ifPresent:[:engineClass| engine _ (engineClass defaultForPlatformOn: aForm)]. engine ifNil:[ "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: 3; cellSize: 2; warpBits. ^self ]. "Otherwise use the 3D engine for our purposes" engine viewport: aForm boundingBox. engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). engine texture: self. engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). engine finish.! ! !Form methodsFor: 'displaying' stamp: 'ar 5/14/2001 23:33'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: rule fillColor: aForm aDisplayMedium copyBits: self boundingBox from: self at: aDisplayPoint + self offset clippingBox: clipRectangle rule: rule fillColor: aForm map: (self colormapIfNeededFor: aDisplayMedium). ! ! !Form methodsFor: 'displaying' stamp: 'ar 5/17/2001 15:40'! displayResourceFormOn: aForm "a special display method for blowing up resource thumbnails" | engine tx cmap blitter | self extent = aForm extent ifTrue:[^self displayOn: aForm]. Smalltalk at: #B3DRenderEngine ifPresentAndInMemory: [:engineClass | engine _ engineClass defaultForPlatformOn: aForm]. engine ifNil:[ "We've got no bilinear interpolation. Use WarpBlt instead" (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: 3; cellSize: 2; warpBits. ^self ]. tx _ self asTexture. (blitter _ BitBlt current toForm: tx) sourceForm: self; destRect: aForm boundingBox; sourceOrigin: 0@0; combinationRule: Form paint. "map transparency to current World background color" (World color respondsTo: #pixelWordForDepth:) ifTrue: [ cmap _ Bitmap new: (self depth <= 8 ifTrue: [1 << self depth] ifFalse: [4096]). cmap at: 1 put: (tx pixelWordFor: World color). blitter colorMap: cmap. ]. blitter copyBits. engine viewport: aForm boundingBox. engine material: ((Smalltalk at: #B3DMaterial) new emission: Color white). engine texture: tx. engine render: ((Smalltalk at: #B3DIndexedQuadMesh) new plainTextureRect). engine finish. "the above, using bilinear interpolation doesn't leave transparent pixel values intact" (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: Form and; colorMap: (Color maskingMap: self depth); warpBits.! ! !Form methodsFor: 'displaying' stamp: 'ar 3/2/2001 21:32'! displayScaledOn: aForm "Display the receiver on aForm, scaling if necessary. Form fromUser displayScaledOn: Display. " self extent = aForm extent ifTrue:[^self displayOn: aForm]. (WarpBlt current toForm: aForm) sourceForm: self destRect: aForm boundingBox; combinationRule: Form paint; cellSize: 2; warpBits.! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:41'! comeFullyUpOnReload: smartRefStream bits isForm ifFalse:[^self]. "make sure the resource gets loaded afterwards" ResourceCollector current ifNil:[^self]. ResourceCollector current noteResource: bits replacing: self. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 16:16'! objectForDataStream: refStream | prj repl | prj _ refStream project. prj ifNil:[^super objectForDataStream: refStream]. ResourceCollector current ifNil:[^super objectForDataStream: refStream]. repl _ ResourceCollector current objectForDataStream: refStream fromForm: self. ^repl! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:44'! readAttributesFrom: aBinaryStream | offsetX offsetY | depth _ aBinaryStream next. (self depth isPowerOfTwo and: [self depth between: 1 and: 32]) ifFalse: [self error: 'invalid depth; bad Form file?']. width _ aBinaryStream nextWord. height _ aBinaryStream nextWord. offsetX _ aBinaryStream nextWord. offsetY _ aBinaryStream nextWord. offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536]. offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536]. offset _ Point x: offsetX y: offsetY. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:43'! readBitsFrom: aBinaryStream bits _ Bitmap newFromStream: aBinaryStream. bits size = self bitsSize ifFalse: [self error: 'wrong bitmap size; bad Form file?']. ^ self ! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:44'! readFrom: aBinaryStream "Reads the receiver from the given binary stream with the format: depth, extent, offset, bits." self readAttributesFrom: aBinaryStream. self readBitsFrom: aBinaryStream! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 2/24/2001 22:39'! replaceByResource: aForm "Replace the receiver by some resource that just got loaded" (self extent = aForm extent and:[self depth = aForm depth]) ifTrue:[ bits _ aForm bits. ].! ! !Form methodsFor: 'fileIn/Out' stamp: 'nk 12/31/2003 16:06'! store15To24HexBitsOn:aStream | buf i lineWidth | "write data for 16-bit form, optimized for encoders writing directly to files to do one single file write rather than 12. I'm not sure I understand the significance of the shifting pattern, but I think I faithfully translated it from the original" lineWidth _ 0. buf _ String new: 12. bits do: [:word | i _ 0. "upper pixel" buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -32) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -27) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -17) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -22) bitAnd: 8) asHexDigit. "lower pixel" buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -16) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -11) bitAnd: 8) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -1) bitAnd: 15) asHexDigit. buf at: (i _ i + 1) put: ((word bitShift: -6) bitAnd: 8) asHexDigit. aStream nextPutAll: buf. lineWidth _ lineWidth + 12. lineWidth > 100 ifTrue: [ aStream cr. lineWidth _ 0 ]. "#( 31 26 21 15 10 5 ) do:[:startBit | ]" ].! ! !Form methodsFor: 'fileIn/Out' stamp: 'laza 3/29/2004 12:21'! storeBitsOn:aStream base:anInteger bits do: [:word | anInteger = 10 ifTrue: [aStream space] ifFalse: [aStream crtab: 2]. word storeOn: aStream base: anInteger]. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 3/3/2001 15:50'! unhibernate "If my bitmap has been compressed into a ByteArray, then expand it now, and return true." | resBits | bits isForm ifTrue:[ resBits _ bits. bits _ Bitmap new: self bitsSize. resBits displayResourceFormOn: self. ^true]. bits == nil ifTrue:[bits _ Bitmap new: self bitsSize. ^true]. (bits isMemberOf: ByteArray) ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true]. ^ false! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:35'! writeAttributesOn: file self unhibernate. file nextPut: depth. file nextWordPut: width. file nextWordPut: height. file nextWordPut: ((self offset x) >=0 ifTrue: [self offset x] ifFalse: [self offset x + 65536]). file nextWordPut: ((self offset y) >=0 ifTrue: [self offset y] ifFalse: [self offset y + 65536]). ! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 6/16/2002 17:53'! writeBMPfileNamed: fName "Display writeBMPfileNamed: 'display.bmp'" BMPReadWriter putForm: self onFileNamed: fName! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:35'! writeBitsOn: file bits writeOn: file! ! !Form methodsFor: 'fileIn/Out' stamp: 'sw 2/20/2002 15:37'! writeJPEGfileNamed: fileName "Write a JPEG file to the given filename using default settings" self writeJPEGfileNamed: fileName progressive: false " Display writeJPEGfileNamed: 'display.jpeg' Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' "! ! !Form methodsFor: 'fileIn/Out' stamp: 'sw 2/20/2002 15:29'! writeJPEGfileNamed: fileName progressive: aBoolean "Write a JPEG file to the given filename using default settings. Make it progressive or not, depending on the boolean argument" JPEGReadWriter2 putForm: self quality: -1 "default" progressiveJPEG: aBoolean onFileNamed: fileName " Display writeJPEGfileNamed: 'display.jpeg' progressive: false. Form fromUser writeJPEGfileNamed: 'yourPatch.jpeg' progressive: true "! ! !Form methodsFor: 'fileIn/Out' stamp: 'mu 8/17/2003 00:36'! writeOn: file "Write the receiver on the file in the format depth, extent, offset, bits." self writeAttributesOn: file. self writeBitsOn: file! ! !Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:09'! eraseShape: bwForm "use bwForm as a mask to clear all pixels where bwForm has 1's" ((BitBlt current destForm: self sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits. ! ! !Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! fillFromXYColorBlock: colorBlock "General Gradient Fill. Supply relative x and y in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | poker yRel xRel | poker _ BitBlt current bitPokerToForm: self. 0 to: height-1 do: [:y | yRel _ y asFloat / (height-1) asFloat. 0 to: width-1 do: [:x | xRel _ x asFloat / (width-1) asFloat. poker pixelAt: x@y put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: self depth)]] " | d | ((Form extent: 100@20 depth: Display depth) fillFromXYColorBlock: [:x :y | d _ 1.0 - (x - 0.5) abs - (y - 0.5) abs. Color r: d g: 0 b: 1.0-d]) display "! ! !Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! findShapeAroundSeedBlock: seedBlock "Build a shape that is black in any region marked by seedBlock. SeedBlock will be supplied a form, in which to blacken various pixels as 'seeds'. Then the seeds are smeared until there is no change in the smear when it fills the region, ie, when smearing hits a black border and thus goes no further." | smearForm previousSmear all count smearPort | self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." all _ self boundingBox. smearForm _ Form extent: self extent. smearPort _ BitBlt current toForm: smearForm. seedBlock value: smearForm. "Blacken seeds to be smeared" smearPort copyForm: self to: 0@0 rule: Form erase. "Clear any in black" previousSmear _ smearForm deepCopy. count _ 1. [count = 10 and: "check for no change every 10 smears" [count _ 1. previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse. previousSmear isAllWhite]] whileFalse: [smearPort copyForm: smearForm to: 1@0 rule: Form under. smearPort copyForm: smearForm to: -1@0 rule: Form under. "After horiz smear, trim around the region border" smearPort copyForm: self to: 0@0 rule: Form erase. smearPort copyForm: smearForm to: 0@1 rule: Form under. smearPort copyForm: smearForm to: 0@-1 rule: Form under. "After vert smear, trim around the region border" smearPort copyForm: self to: 0@0 rule: Form erase. count _ count+1. count = 9 ifTrue: "Save penultimate smear for comparison" [previousSmear copy: all from: 0@0 in: smearForm rule: Form over]]. "Now paint the filled region in me with aHalftone" ^ smearForm! ! !Form methodsFor: 'filling' stamp: 'ar 5/14/2001 23:46'! floodFill2: aColor at: interiorPoint "Fill the shape (4-connected) at interiorPoint. The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990. NOTE: This is a less optimized variant for flood filling which is precisely along the lines of Heckbert's algorithm. For almost all cases #floodFill:at: will be faster (see the comment there) but this method is left in both as reference and as a fallback if such a strange case is encountered in reality." | peeker poker stack old new x y top x1 x2 dy left goRight | peeker _ BitBlt current bitPeekerFromForm: self. poker _ BitBlt current bitPokerToForm: self. stack _ OrderedCollection new: 50. "read old pixel value" old _ peeker pixelAt: interiorPoint. "compute new value" new _ self pixelValueFor: aColor. old = new ifTrue:[^self]. "no point, is there?!!" x _ interiorPoint x. y _ interiorPoint y. (y >= 0 and:[y < height]) ifTrue:[ stack addLast: {y. x. x. 1}. "y, left, right, dy" stack addLast: {y+1. x. x. -1}]. [stack isEmpty] whileFalse:[ top _ stack removeLast. y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4. y _ y + dy. "Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled. Now explore adjacent pixels in scanline y." x _ x1. [x >= 0 and:[(peeker pixelAt: x@y) = old]] whileTrue:[ poker pixelAt: x@y put: new. x _ x - 1]. goRight _ x < x1. left _ x+1. (left < x1 and:[y-dy >= 0 and:[y-dy < height]]) ifTrue:[stack addLast: {y. left. x1-1. 0-dy}]. goRight ifTrue:[x _ x1 + 1]. [ goRight ifTrue:[ [x < width and:[(peeker pixelAt: x@y) = old]] whileTrue:[ poker pixelAt: x@y put: new. x _ x + 1]. (y+dy >= 0 and:[y+dy < height]) ifTrue:[stack addLast: {y. left. x-1. dy}]. (x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]]. [(x _ x + 1) <= x2 and:[(peeker pixelAt: x@y) ~= old]] whileTrue. left _ x. goRight _ true. x <= x2] whileTrue. ]. ! ! !Form methodsFor: 'filling' stamp: 'di 10/20/2001 22:03'! floodFill: aColor at: interiorPoint Preferences areaFillsAreVeryTolerant ifTrue: [^ self floodFill: aColor at: interiorPoint tolerance: 0.2]. Preferences areaFillsAreTolerant ifTrue: [^ self floodFill: aColor at: interiorPoint tolerance: 0.1]. ^ self floodFill: aColor at: interiorPoint tolerance: 0 ! ! !Form methodsFor: 'filling' stamp: 'di 10/20/2001 08:47'! floodFill: aColor at: interiorPoint tolerance: tolerance "Fill the shape (4-connected) at interiorPoint. The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990. NOTE (ar): This variant has been heavily optimized to prevent the overhead of repeated calls to BitBlt. Usually this is a really big winner but the runtime now depends a bit on the complexity of the shape to be filled. For extremely complex shapes (say, a Hilbert curve) with very few pixels to fill it can be slower than #floodFill2:at: since it needs to repeatedly read the source bits. However, in all practical cases I found this variant to be 15-20 times faster than anything else. Further note (di): I have added a feature that allows this routine to fill areas of approximately constant color (such as photos, scans, and jpegs). It does this by computing a color map for the peeker that maps all colors close to 'old' into colors identical to old. This mild colorblindness achieves the desired effect with no further change or degradation of the algorithm. tolerance should be 0 (exact match), or a value corresponding to those returned by Color>>diff:, with 0.1 being a reasonable starting choice." | peeker poker stack old new x y top x1 x2 dy left goRight span spanBits w box debug | debug _ false. "set it to true to see the filling process" box _ interiorPoint extent: 1@1. span _ Form extent: width@1 depth: 32. spanBits _ span bits. peeker _ BitBlt current toForm: span. peeker sourceForm: self; combinationRule: 3; width: width; height: 1. "read old pixel value" peeker sourceOrigin: interiorPoint; destOrigin: interiorPoint x @ 0; width: 1; copyBits. old _ spanBits at: interiorPoint x + 1. "compute new value (take care since the algorithm will fail if old = new)" new _ self privateFloodFillValue: aColor. old = new ifTrue: [^ box]. tolerance > 0 ifTrue: ["Set up color map for approximate fills" peeker colorMap: (self floodFillMapFrom: self to: span mappingColorsWithin: tolerance to: old)]. poker _ BitBlt current toForm: self. poker fillColor: aColor; combinationRule: 3; width: width; height: 1. stack _ OrderedCollection new: 50. x _ interiorPoint x. y _ interiorPoint y. (y >= 0 and:[y < height]) ifTrue:[ stack addLast: {y. x. x. 1}. "y, left, right, dy" stack addLast: {y+1. x. x. -1}]. [stack isEmpty] whileFalse:[ debug ifTrue:[self displayOn: Display]. top _ stack removeLast. y _ top at: 1. x1 _ top at: 2. x2 _ top at: 3. dy _ top at: 4. y _ y + dy. debug ifTrue:[ (Line from: (x1-1)@y to: (x2+1)@y withForm: (Form extent: 1@1 depth: 8) fillWhite) displayOn: Display]. "Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled. Now explore adjacent pixels in scanline y." peeker sourceOrigin: 0@y; destOrigin: 0@0; width: width; copyBits. "Note: above is necessary since we don't know where we'll end up filling" x _ x1. w _ 0. [x >= 0 and:[(spanBits at: x+1) = old]] whileTrue:[ w _ w + 1. x _ x - 1]. w > 0 ifTrue:[ "overwrite pixels" poker destOrigin: x+1@y; width: w; copyBits. box _ box quickMerge: ((x+1@y) extent: w@1)]. goRight _ x < x1. left _ x+1. (left < x1 and:[y-dy >= 0 and:[y-dy < height]]) ifTrue:[stack addLast: {y. left. x1-1. 0-dy}]. goRight ifTrue:[x _ x1 + 1]. [ goRight ifTrue:[ w _ 0. [x < width and:[(spanBits at: x+1) = old]] whileTrue:[ w _ w + 1. x _ x + 1]. w > 0 ifTrue:[ "overwrite pixels" poker destOrigin: (x-w)@y; width: w; copyBits. box _ box quickMerge: ((x-w@y) extent: w@1)]. (y+dy >= 0 and:[y+dy < height]) ifTrue:[stack addLast: {y. left. x-1. dy}]. (x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]]. [(x _ x + 1) <= x2 and:[(spanBits at: x+1) ~= old]] whileTrue. left _ x. goRight _ true. x <= x2] whileTrue. ]. ^box! ! !Form methodsFor: 'filling' stamp: 'di 10/20/2001 10:09'! floodFillMapFrom: sourceForm to: scanlineForm mappingColorsWithin: dist to: centerPixVal "This is a helper routine for floodFill. It's written for clarity (scanning the entire map using colors) rather than speed (which would require hacking rgb components in the nieghborhood of centerPixVal. Note that some day a better proximity metric would be (h s v) where tolerance could be reduced in hue." | colorMap centerColor | scanlineForm depth = 32 ifFalse: [self error: 'depth 32 assumed']. "First get a modifiable identity map" colorMap _ (Color cachedColormapFrom: sourceForm depth to: scanlineForm depth) copy. centerColor _ Color colorFromPixelValue: (centerPixVal bitOr: 16rFFe6) depth: scanlineForm depth. "Now replace all entries that are close to the centerColor" 1 to: colorMap size do: [:i | ((Color colorFromPixelValue: ((colorMap at: i) bitOr: 16rFFe6) depth: scanlineForm depth) diff: centerColor) <= dist ifTrue: [colorMap at: i put: centerPixVal]]. ^ colorMap! ! !Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:10'! shapeFill: aColor interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind | self depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." "bwForm _ self makeBWForm: interiorColor." "won't work for two whites" interiorPixVal _ self pixelValueAt: interiorPoint. bwForm _ Form extent: self extent. map _ Bitmap new: (1 bitShift: (self depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd _ self depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd _ bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: self depth. ind _ color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm _ bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. "Finally use that shape as a mask to flood the region with color" self eraseShape: bwForm. self fillShape: bwForm fillColor: aColor. ^ bwForm! ! !Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! shapeFill: aColor seedBlock: seedBlock self depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms']. (self findShapeAroundSeedBlock: seedBlock) displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form under fillColor: aColor ! ! !Form methodsFor: 'image manipulation' stamp: 'ar 5/17/2001 15:40'! replaceColor: oldColor withColor: newColor "Replace one color with another everywhere is this form" | cm newInd target ff | self depth = 32 ifTrue: [cm _ (Color cachedColormapFrom: 16 to: 32) copy] ifFalse: [cm _ Bitmap new: (1 bitShift: (self depth min: 15)). 1 to: cm size do: [:i | cm at: i put: i - 1]]. newInd _ newColor pixelValueForDepth: self depth. cm at: (oldColor pixelValueForDepth: (self depth min: 16))+1 put: newInd. target _ newColor isTransparent ifTrue: [ff _ Form extent: self extent depth: depth. ff fillWithColor: newColor. ff] ifFalse: [self]. (BitBlt current toForm: target) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form paint; destX: 0 destY: 0 width: width height: height; colorMap: cm; copyBits. newColor = Color transparent ifTrue: [target displayOn: self].! ! !Form methodsFor: 'image manipulation' stamp: 'LB 8/26/2002 18:08'! stencil "return a 1-bit deep, black-and-white stencil of myself" | canvas | canvas _ FormCanvas extent: self extent depth: 1. canvas fillColor: (Color white). canvas stencil: self at: 0@0 sourceRect: (Rectangle origin: 0@0 corner: self extent) color: Color black. ^ canvas form ! ! !Form methodsFor: 'initialize-release' stamp: 'ar 5/17/2001 22:54'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver and can be used for accelerated blts" ^Form extent: extentPoint depth: self nativeDepth! ! !Form methodsFor: 'initialize-release' stamp: 'ar 6/16/2002 18:39'! swapEndianness "Swap from big to little endian pixels and vice versa" depth := 0 - depth.! ! !Form methodsFor: 'other' stamp: 'ar 12/12/2003 18:24'! fixAlpha "Fix the alpha channel if the receiver is 32bit" | bb | self depth = 32 ifFalse:[^self]. bb := BitBlt toForm: self. bb combinationRule: 40 "fixAlpha:with:". bb copyBits.! ! !Form methodsFor: 'other' stamp: 'sw 5/3/2001 16:23'! graphicForViewerTab "Answer the graphic to be used in the tab of a viewer open on me" ^ self! ! !Form methodsFor: 'other' stamp: 'RAA 1/30/2002 16:42'! relativeTextAnchorPosition ^nil "so forms can be in TextAnchors"! ! !Form methodsFor: 'other' stamp: 'dgd 8/26/2003 21:44'! setAsBackground "Set this form as a background image." | world newColor | Smalltalk isMorphic ifTrue: [world _ self currentWorld. newColor _ InfiniteForm with: self. self rememberCommand: (Command new cmdWording: 'set background to a picture' translated; undoTarget: world selector: #color: argument: world color; redoTarget: world selector: #color: argument: newColor). world color: newColor] ifFalse: [ScheduledControllers screenController model form: self. Display restoreAfter: []]! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:42'! colorAt: aPoint "Return the color in the pixel at the given point. " ^ Color colorFromPixelValue: (self pixelValueAt: aPoint) depth: self depth ! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/14/2001 23:46'! colorAt: aPoint put: aColor "Store a Color into the pixel at coordinate aPoint. " self pixelValueAt: aPoint put: (self pixelValueFor: aColor). "[Sensor anyButtonPressed] whileFalse: [Display colorAt: Sensor cursorPoint put: Color red]" ! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/17/2001 15:39'! isTransparentAt: aPoint "Return true if the receiver is transparent at the given point." self depth = 1 ifTrue: [^ false]. "no transparency at depth 1" ^ (self pixelValueAt: aPoint) = (self pixelValueFor: Color transparent) ! ! !Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:36'! bitsPerComponent ^self depth <= 8 ifTrue:[self depth] ifFalse:[8]. ! ! !Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:39'! decodeArray ^self depth <= 8 ifTrue:['[1 0]'] ifFalse:['[0 1 0 1 0 1 ]']. ! ! !Form methodsFor: 'postscript generation' stamp: 'RAA 4/20/2001 15:40'! encodePostscriptOn: aStream self unhibernate. "since current Postscript support treats 8-bit forms as 0 to 255 gray scale, convert to 16 first so we get more faithful results" self depth <= 8 ifTrue: [^(self asFormOfDepth: 16) encodePostscriptOn: aStream]. ^ self printPostscript: aStream operator: (self depth = 1 ifTrue: ['imagemask'] ifFalse: ['image'])! ! !Form methodsFor: 'postscript generation' stamp: 'ar 5/17/2001 15:43'! numComponents ^self depth <= 8 ifTrue:[1] ifFalse:[3]. ! ! !Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'! printPostscript: aStream operator: operator aStream preserveStateDuring: [:inner | inner rectclip: (0 @ 0 extent: width @ height). self setColorspaceOn: inner. inner print: '[ '; cr; print: '/ImageType 1'; cr; print: '/ImageMatrix [1 0 0 1 0 0]'; cr; print: '/MultipleDataSources false'; cr; print: '/DataSource level1 { { currentfile '; write: self bytesPerRow; print: ' string readhexstring pop }} bind { currentfile /ASCIIHexDecode filter } ifelse'; cr; print: '/Width '; write: self paddedWidth; cr; print: '/Height '; write: self height; cr; print: '/Decode '; print: self decodeArray; cr; print: '/BitsPerComponent '; write: self bitsPerComponent; cr; print: 'makeDict '; print: operator; cr. self storePostscriptHexOn: inner. inner print: $>; cr. inner cr]. aStream cr! ! !Form methodsFor: 'postscript generation' stamp: 'nk 12/31/2003 15:46'! storePostscriptHexOn: inner self depth <= 8 ifTrue: [self storeHexBitsOn: inner]. self depth = 16 ifTrue: [self store15To24HexBitsOn: inner]. self depth = 32 ifTrue: [self store32To24HexBitsOn: inner]! ! !Form methodsFor: 'resources' stamp: 'ar 12/9/2002 16:04'! readNativeResourceFrom: byteStream | img aStream | (byteStream isKindOf: FileStream) ifTrue:[ "Ugly, but ImageReadWriter will send #reset which is implemented as #reopen and we may not be able to do so." aStream _ RWBinaryOrTextStream with: byteStream contents. ] ifFalse:[ aStream _ byteStream. ]. img _ [ImageReadWriter formFromStream: aStream] on: Error do:[:ex| nil]. img ifNil:[^nil]. (img isColorForm and:[self isColorForm]) ifTrue:[ | cc | cc := img colors. img colors: nil. img displayOn: self. img colors: cc. ] ifFalse:[ img displayOn: self. ]. img _ nil.! ! !Form methodsFor: 'resources' stamp: 'nk 7/30/2004 17:53'! readResourceFrom: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." | bitsSize msb | (aStream next: 4) asString = self resourceTag ifFalse: [aStream position: aStream position - 4. ^self readNativeResourceFrom: aStream]. width := aStream nextNumber: 4. height := aStream nextNumber: 4. depth := aStream nextNumber: 4. bitsSize := aStream nextNumber: 4. bitsSize = 0 ifFalse: [bits := aStream next: bitsSize. ^self]. msb := (aStream nextNumber: 4) = 1. bitsSize := aStream nextNumber: 4. bits := Bitmap new: self bitsSize. (Form extent: width @ height depth: depth bits: (aStream next: bitsSize * 4)) displayOn: self. msb = SmalltalkImage current isBigEndian ifFalse: [Bitmap swapBytesIn: bits from: 1 to: bits size]! ! !Form methodsFor: 'resources' stamp: 'ar 2/27/2001 14:56'! resourceTag ^'FORM'! ! !Form methodsFor: 'resources' stamp: 'sd 9/30/2003 13:41'! storeResourceOn: aStream "Store a resource representation of the receiver on aStream. Must be specific to the receiver so that no code is filed out." self hibernate. aStream nextPutAll: self resourceTag asByteArray. "tag" aStream nextNumber: 4 put: width. aStream nextNumber: 4 put: height. aStream nextNumber: 4 put: depth. (bits isMemberOf: ByteArray) ifFalse:[ "must store bitmap" aStream nextNumber: 4 put: 0. "tag" aStream nextNumber: 4 put: (SmalltalkImage current isBigEndian ifTrue:[1] ifFalse:[0]). ]. aStream nextNumber: 4 put: bits size. aStream nextPutAll: bits. ! ! !Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:33'! flipBy: direction centerAt: aPoint "Return a copy of the receiver flipped either #vertical or #horizontal." | newForm quad | newForm _ self class extent: self extent depth: depth. quad _ self boundingBox innerCorners. quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)]) collect: [:i | quad at: i]. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); combinationRule: 3; copyQuad: quad toRect: newForm boundingBox. newForm offset: (self offset flipBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) flipBy: #vertical centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 _ f flipBy: #vertical centerAt: 0@0. (f2 flipBy: #vertical centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! magnify: aRectangle by: scale smoothing: cellSize "Answer a Form created as a scaling of the receiver. Scale may be a Float or even a Point, and may be greater or less than 1.0." | newForm | newForm _ self blankCopyOf: aRectangle scaledBy: scale. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: 3; copyQuad: aRectangle innerCorners toRect: newForm boundingBox. ^ newForm "Dynamic test... [Sensor anyButtonPressed] whileFalse: [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display] " "Scaling test... | f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100). Display restoreAfter: [Sensor waitNoButton. [Sensor anyButtonPressed] whileFalse: [cp _ Sensor cursorPoint. (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]] "! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! magnifyBy: scale "Answer a Form created as a scaling of the receiver. Scale may be a Float or even a Point, and may be greater or less than 1.0." ^ self magnify: self boundingBox by: scale smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! ! !Form methodsFor: 'scaling, rotation' stamp: 'ar 5/14/2001 23:33'! rotateBy: direction centerAt: aPoint "Return a rotated copy of the receiver. direction = #none, #right, #left, or #pi" | newForm quad rot | direction == #none ifTrue: [^ self]. newForm _ self class extent: (direction = #pi ifTrue: [width@height] ifFalse: [height@width]) depth: depth. quad _ self boundingBox innerCorners. rot _ #(right pi left) indexOf: direction. (WarpBlt current toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededFor: newForm); combinationRule: 3; copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i]) toRect: newForm boundingBox. newForm offset: (self offset rotateBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: #left centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 _ f rotateBy: #left centerAt: 0@0. (f2 rotateBy: #right centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 16:54'! rotateBy: deg magnify: scale smoothing: cellSize "Rotate the receiver by the indicated number of degrees and magnify. scale can be a Point to make for interesting 3D effects " "rot is the destination form, big enough for any angle." | side rot warp r1 pts p bigSide | side _ 1 + self extent r asInteger. bigSide _ (side asPoint * scale) rounded. rot _ self class extent: bigSide depth: self depth. warp _ (WarpBlt current toForm: rot) sourceForm: self; colorMap: (self colormapIfNeededFor: rot); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: Form paint. r1 _ (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center. "Rotate the corners of the source rectangle." pts _ r1 innerCorners collect: [:pt | p _ pt - r1 center. (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @ (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))]. warp copyQuad: pts toRect: rot boundingBox. ^ rot " | a f | f _ Form fromDisplay: (0@0 extent: 200@200). a _ 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a _ a+5) magnify: 0.75@2 smoothing: 2) display]. f display "! ! !Form methodsFor: 'scaling, rotation' stamp: 'tpr 9/28/2004 16:55'! rotateBy: deg smoothing: cellSize "Rotate the receiver by the indicated number of degrees." ^self rotateBy: deg magnify: 1 smoothing: cellSize " | a f | f _ Form fromDisplay: (0@0 extent: 200@200). a _ 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a _ a+5) smoothing: 2) display]. f display "! ! !Form methodsFor: 'testing' stamp: 'ar 5/15/2001 16:14'! hasNonStandardPalette "Return true if the receiver has a non-standard palette. Non-standard means that RGBA components may be located at positions differing from the standard Squeak RGBA layout at the receiver's depth." ^false! ! !Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:46'! isBigEndian "Return true if the receiver contains big endian pixels, meaning the left-most pixel is stored in the most significant bits of a word." ^depth > 0! ! !Form methodsFor: 'testing' stamp: 'ar 10/30/2000 23:23'! isForm ^true! ! !Form methodsFor: 'testing' stamp: 'ar 5/17/2001 15:47'! isLittleEndian "Return true if the receiver contains little endian pixels, meaning the left-most pixel is stored in the least significant bits of a word." ^depth < 0! ! !Form methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^self depth = 32! ! !Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:42'! fadeImageCoarse: otherImage at: topLeft "Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" | pix j d | d _ self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | i=1 ifTrue: [pix _ (1 bitShift: d) - 1. 1 to: 8//d-1 do: [:q | pix _ pix bitOr: (pix bitShift: d*4)]]. i <= 16 ifTrue: [j _ i-1//4+1. (0 to: 28 by: 4) do: [:k | mask bits at: j+k put: ((mask bits at: j+k) bitOr: (pix bitShift: i-1\\4*d))]. "mask display." true] ifFalse: [false]]! ! !Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:41'! fadeImageFine: otherImage at: topLeft "Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40" | pix j ii d | d _ self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | i=1 ifTrue: [pix _ (1 bitShift: d) - 1. 1 to: 8//d-1 do: [:q | pix _ pix bitOr: (pix bitShift: d*4)]]. i <= 16 ifTrue: [ii _ #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i. j _ ii//4+1. (0 to: 28 by: 4) do: [:k | mask bits at: j+k put: ((mask bits at: j+k) bitOr: (pix bitShift: ii\\4*d))]. true] ifFalse: [false]]! ! !Form methodsFor: 'transitions' stamp: 'ar 5/17/2001 15:39'! fadeImageVert: otherImage at: topLeft "Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10" | d | d _ self depth. ^ self fadeImage: otherImage at: topLeft indexAndMaskDo: [:i :mask | mask fill: ((mask width//2//d-i*d)@0 extent: i*2*d@mask height) fillColor: Color black. i <= (mask width//d)]! ! !Form methodsFor: 'private' stamp: 'ar 10/30/2000 23:22'! setResourceBits: aForm "Private. Really. Used for setting the 'resource bits' when externalizing some form" bits _ aForm.! ! !Form commentStamp: 'ls 1/4/2004 17:16' prior: 0! A rectangular array of pixels, used for holding images. All pictures, including character images are Forms. The depth of a Form is how many bits are used to specify the color at each pixel. The actual bits are held in a Bitmap, whose internal structure is different at each depth. Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. Forms are indexed starting at 0 instead of 1; thus, the top-left pixel of a Form has coordinates 0@0. Forms are combined using BitBlt. See the comment in class BitBlt. Forms that repeat many times to fill a large destination are InfiniteForms. colorAt: x@y Returns the abstract Color at this location displayAt: x@y shows this form on the screen displayOn: aMedium at: x@y shows this form in a Window, a Form, or other DisplayMedium fillColor: aColor Set all the pixels to the color. edit launch an editor to change the bits of this form. pixelValueAt: x@y The encoded color. The encoding depends on the depth. ! ]style[(223 6 62 5 374 6 11 23 64 12 40 5 337)f1,f1LBitmap Definition;,f1,f1LColor Definition;,f1,f1LBitBlt Definition;,f1,f1LBitBlt Comment;,f1,f1LInfiniteForm Definition;,f1,f1RColor;,f1! !Form class methodsFor: 'instance creation' stamp: 'nk 7/7/2003 18:19'! fromBinaryStream: aBinaryStream "Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format." | firstByte | aBinaryStream binary. firstByte _ aBinaryStream next. firstByte = 1 ifTrue: [ "old Squeakform format" ^ self new readFromOldFormat: aBinaryStream]. firstByte = 2 ifTrue: [ "new Squeak form format" ^ self new readFrom: aBinaryStream]. "Try for JPG, GIF, or PCX..." "Note: The following call closes the stream." ^ ImageReadWriter formFromStream: aBinaryStream ! ! !Form class methodsFor: 'instance creation' stamp: 'mir 11/19/2001 14:13'! fromFileNamed: fileName "Read a Form or ColorForm from the given file." | file form | file _ (FileStream readOnlyFileNamed: fileName) binary. form _ self fromBinaryStream: file. Smalltalk isMorphic ifTrue:[ Project current resourceManager addResource: form url: (FileDirectory urlForFileNamed: file name) asString]. file close. ^ form ! ! !Form class methodsFor: 'mode constants' stamp: 'hg 1/29/2001 17:28'! rgbMul "Answer the integer denoting 'Multiply each color component, their values regarded as fractions of 1' rule." ^ 37! ! !Form class methodsFor: 'BMP file reading' stamp: 'ar 6/16/2002 17:41'! fromBMPFile: aBinaryStream "Obsolete" ^self fromBinaryStream: aBinaryStream.! ! !Form class methodsFor: 'BMP file reading' stamp: 'ar 6/16/2002 17:41'! fromBMPFileNamed: fileName "Obsolete" ^self fromFileNamed: fileName ! ! !Form class methodsFor: 'initialize-release' stamp: 'hg 8/3/2000 16:25'! initialize FileList registerFileReader: self! ! !Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 12:47'! importImage: fullName "Import the given image file and store the resulting Form in the default Imports. The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." Imports default importImageFromFileNamed: fullName. ! ! !Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 13:08'! importImageDirectory: dir "Import the given image file and store the resulting Form in the default Imports. The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." Imports default importImageDirectory: dir ! ! !Form class methodsFor: 'fileIn/Out' stamp: 'nk 6/12/2004 12:55'! importImageDirectoryWithSubdirectories: dir "Import the given image file and store the resulting Form in the default Imports. The image is named with the short filename up to the first period, possibly with additions from the directory path to make it unique." Imports default importImageDirectoryWithSubdirectories: dir ! ! !Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 12:56'! fileReaderServicesForDirectory: aFileDirectory ^{ self serviceImageImportDirectory. self serviceImageImportDirectoryWithSubdirectories. }! ! !Form class methodsFor: 'file list services' stamp: 'nk 7/16/2003 18:01'! fileReaderServicesForFile: fullName suffix: suffix ^((ImageReadWriter allTypicalFileExtensions add: '*'; add: 'form'; yourself) includes: suffix) ifTrue: [ self services ] ifFalse: [#()] ! ! !Form class methodsFor: 'file list services' stamp: 'hg 8/3/2000 16:26'! openAsBackground: fullName "Set an image as a background image. Support Squeak's common file format (GIF, JPG, PNG, 'Form stoteOn: (run coded)' and BMP)" (self fromFileNamed: fullName) setAsBackground! ! !Form class methodsFor: 'file list services' stamp: 'nk 1/6/2004 12:36'! openImageInWindow: fullName "Handle five file formats: GIF, JPG, PNG, Form storeOn: (run coded), and BMP. Fail if file format is not recognized." | image myStream | myStream _ (FileStream readOnlyFileNamed: fullName) binary. image _ self fromBinaryStream: myStream. myStream close. Smalltalk isMorphic ifTrue:[ Project current resourceManager addResource: image url: (FileDirectory urlForFileNamed: fullName) asString. ]. Smalltalk isMorphic ifTrue: [(World drawingClass withForm: image) openInWorld] ifFalse: [FormView open: image named: fullName]! ! !Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 01:38'! serviceImageAsBackground "Answer a service for setting the desktop background from a given graphical file's contents" ^ SimpleServiceEntry provider: self label: 'use graphic as background' selector: #openAsBackground: description: 'use the graphic as the background for the desktop' buttonLabel: 'background'! ! !Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:16'! serviceImageImportDirectory "Answer a service for reading a graphic into ImageImports" ^(SimpleServiceEntry provider: self label: 'import all images from this directory' selector: #importImageDirectory: description: 'Load all graphics found in this directory, adding them to the ImageImports repository.' buttonLabel: 'import dir') argumentGetter: [ :fileList | fileList directory ]; yourself ! ! !Form class methodsFor: 'file list services' stamp: 'nk 6/12/2004 13:15'! serviceImageImportDirectoryWithSubdirectories "Answer a service for reading all graphics from a directory and its subdirectories into ImageImports" ^(SimpleServiceEntry provider: self label: 'import all images from here and subdirectories' selector: #importImageDirectoryWithSubdirectories: description: 'Load all graphics found in this directory and its subdirectories, adding them to the ImageImports repository.' buttonLabel: 'import subdirs') argumentGetter: [ :fileList | fileList directory ]; yourself ! ! !Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 01:39'! serviceImageImports "Answer a service for reading a graphic into ImageImports" ^ SimpleServiceEntry provider: self label: 'read graphic into ImageImports' selector: #importImage: description: 'Load a graphic, placing it in the ImageImports repository.' buttonLabel: 'import'! ! !Form class methodsFor: 'file list services' stamp: 'sw 2/17/2002 00:31'! serviceOpenImageInWindow "Answer a service for opening a graphic in a window" ^ SimpleServiceEntry provider: self label: 'open graphic in a window' selector: #openImageInWindow: description: 'open a graphic file in a window' buttonLabel: 'open'! ! !Form class methodsFor: 'file list services' stamp: 'sd 2/1/2002 21:43'! services ^ Array with: self serviceImageImports with: self serviceOpenImageInWindow with: self serviceImageAsBackground ! ! !Form class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 12/31/2001 03:26'! contentsOfArea: aRectangle into: aForm | bb | self flush. bb _ BitBlt toForm: aForm. bb sourceForm: form; combinationRule: Form over; sourceX: (aRectangle left + origin x); sourceY: (aRectangle top + origin y); width: aRectangle width; height: aRectangle height; copyBits. ^aForm! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2001 23:34'! line: pt1 to: pt2 brushForm: brush | offset | offset _ origin. self setPaintColor: Color black. port sourceForm: brush; fillColor: nil; sourceRect: brush boundingBox; colorMap: (brush colormapIfNeededFor: form); drawFrom: (pt1 + offset) to: (pt2 + offset)! ! !FormCanvas methodsFor: 'drawing' stamp: 'yo 1/23/2003 17:50'! paragraph3: para bounds: bounds color: c | scanner | self setPaintColor: c. scanner _ (port clippedBy: (bounds translateBy: origin)) displayScannerForMulti: para foreground: (self shadowColor ifNil:[c]) background: Color transparent ignoreColorChanges: self shadowColor notNil. para displayOnTest: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. ! ! !FormCanvas methodsFor: 'drawing' stamp: 'di 9/12/2001 21:38'! paragraph: para bounds: bounds color: c | scanner | self setPaintColor: c. scanner _ (port clippedBy: (bounds translateBy: origin)) displayScannerFor: para foreground: (self shadowColor ifNil:[c]) background: Color transparent ignoreColorChanges: self shadowColor notNil. para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. ! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 9/9/2000 22:18'! render: anObject "Do some 3D operations with the object if possible" ^self asBalloonCanvas render: anObject! ! !FormCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:58'! roundCornersOf: aMorph in: bounds during: aBlock aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'tpr 9/15/2004 10:27'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" self setPaintColor: aColor. port colorMap: stencilForm maskingMap. port stencil: stencilForm at: aPoint + origin sourceRect: sourceRect.! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'ar 12/30/2001 16:36'! warpImage: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." | tfm | tfm _ (MatrixTransform2x3 withOffset: origin) composedWithLocal: aTransform. ^self privateWarp: aForm transform: tfm at: extraOffset sourceRect: sourceRect cellSize: cellSize! ! !FormCanvas methodsFor: 'drawing-ovals' stamp: 'di 5/25/2001 01:40'! fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor | rect | "draw the border of the oval" rect _ (r translateBy: origin) truncated. (borderWidth = 0 or: [borderColor isTransparent]) ifFalse:[ self setFillColor: borderColor. (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [port frameOval: rect borderWidth: borderWidth] ifFalse: [port fillOval: rect]]. "faster this way" "fill the inside" fillColor isTransparent ifFalse: [self setFillColor: fillColor. port fillOval: (rect insetBy: borderWidth)]. ! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'RAA 2/6/2001 14:00'! infiniteFillRectangle: aRectangle fillStyle: aFillStyle | additionalOffset rInPortTerms clippedPort targetTopLeft clipOffset ex | "this is a bit of a kludge to get the form to be aligned where I *think* it should be. something better is needed, but not now" additionalOffset _ 0@0. ex _ aFillStyle form extent. rInPortTerms _ aRectangle translateBy: origin. clippedPort _ port clippedBy: rInPortTerms. targetTopLeft _ clippedPort clipRect topLeft truncateTo: ex. clipOffset _ rInPortTerms topLeft - targetTopLeft. additionalOffset _ (clipOffset \\ ex) - ex. ^aFillStyle displayOnPort: clippedPort offsetBy: additionalOffset ! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 10/18/2004 00:05'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Note: This method has been originally copied from TransformationMorph." | innerRect patchRect sourceQuad warp start subCanvas | (aDisplayTransform isPureTranslation) ifTrue:[ ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated clipRect: aClipRect) ]. "Prepare an appropriate warp from patch to innerRect" innerRect _ aClipRect. patchRect _ (aDisplayTransform globalBoundsToLocal: innerRect) truncated. sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect) collect: [:p | p - patchRect topLeft]. warp _ self warpFrom: sourceQuad toRect: innerRect. warp cellSize: cellSize. "Render the submorphs visible in the clipping rectangle, as patchForm" start _ (self depth = 1 and: [self isShadowDrawing not]) "If this is true B&W, then we need a first pass for erasure." ifTrue: [1] ifFalse: [2]. start to: 2 do: [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W" subCanvas _ self class extent: patchRect extent depth: self depth. i=1 ifTrue: [subCanvas shadowColor: Color black. warp combinationRule: Form erase] ifFalse: [self isShadowDrawing ifTrue: [subCanvas shadowColor: self shadowColor]. warp combinationRule: Form paint]. subCanvas translateBy: patchRect topLeft negated during:[:offsetCanvas| aBlock value: offsetCanvas]. warp sourceForm: subCanvas form; warpBits. warp sourceForm: nil. subCanvas _ nil "release space for next loop"] ! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'! drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c | font | port colorMap: nil. font _ fontOrNil ifNil: [TextStyle defaultFont]. port combinationRule: Form paint. font installOn: port foregroundColor: (self shadowColor ifNil:[c]) backgroundColor: Color transparent. font displayString: aString on: port from: firstIndex to: lastIndex at: (origin + aPoint) kern: 0.! ! !FormCanvas methodsFor: 'drawing-text' stamp: 'ar 2/5/2002 19:03'! drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c | font portRect | port colorMap: nil. portRect _ port clipRect. port clipByX1: bounds left + origin x y1: bounds top + origin y x2: bounds right + origin x y2: bounds bottom + origin y. font _ fontOrNil ifNil: [TextStyle defaultFont]. port combinationRule: Form paint. font installOn: port foregroundColor: (self shadowColor ifNil:[c]) backgroundColor: Color transparent. font displayString: aString asString on: port from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: 0. port clipRect: portRect.! ! !FormCanvas methodsFor: 'private' stamp: 'ar 5/14/2001 23:34'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule.! ! !FormCanvas methodsFor: 'private' stamp: 'ar 8/8/2001 14:21'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededFor: form); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: sourceAlpha.! ! !FormCanvas methodsFor: 'private' stamp: 'ar 12/30/2001 16:35'! privateWarp: aForm transform: aTransform at: extraOffset sourceRect: sourceRect cellSize: cellSize "Warp the given using the appropriate transform and offset." | globalRect sourceQuad warp tfm | tfm _ aTransform. globalRect _ tfm localBoundsToGlobal: sourceRect. sourceQuad _ (tfm sourceQuadFor: globalRect) collect:[:p| p - sourceRect topLeft]. extraOffset ifNotNil:[globalRect _ globalRect translateBy: extraOffset]. warp _ (WarpBlt current toForm: port destForm) combinationRule: Form paint; sourceQuad: sourceQuad destRect: globalRect; clipRect: port clipRect. warp cellSize: cellSize. warp sourceForm: aForm. warp warpBits! ! !FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! setClearColor: aColor "Install a new clear color - e.g., a color is used for clearing the background" | clearColor | clearColor _ aColor ifNil:[Color transparent]. clearColor isColor ifFalse:[ (clearColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. ^port fillPattern: clearColor; combinationRule: Form over]. "Okay, so clearColor really *is* a color" port sourceForm: nil. port combinationRule: Form over. port fillPattern: clearColor. self depth = 8 ifTrue:[ "Use a stipple pattern" port fillColor: (form balancedPatternFor: clearColor)]. ! ! !FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! setFillColor: aColor "Install a new color used for filling." | screen patternWord fillColor | fillColor _ self shadowColor ifNil:[aColor]. fillColor ifNil:[fillColor _ Color transparent]. fillColor isColor ifFalse:[ (fillColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. ^port fillPattern: fillColor; combinationRule: Form over]. "Okay, so fillColor really *is* a color" port sourceForm: nil. fillColor isTranslucent ifFalse:[ port combinationRule: Form over. port fillPattern: fillColor. self depth = 8 ifTrue:[ "In 8 bit depth it's usually a good idea to use a stipple pattern" port fillColor: (form balancedPatternFor: fillColor)]. ^self]. "fillColor is some translucent color" self depth > 8 ifTrue:[ "BitBlt setup for alpha masked transfer" port fillPattern: fillColor. self depth = 16 ifTrue:[port alphaBits: fillColor privateAlpha; combinationRule: 30] ifFalse:[port combinationRule: Form blend]. ^self]. "Can't represent actual transparency -- use stipple pattern" screen _ Color translucentMaskFor: fillColor alpha depth: self depth. patternWord _ form pixelWordFor: fillColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint. ! ! !FormCanvas methodsFor: 'private' stamp: 'tpr 9/15/2004 10:28'! setPaintColor: aColor "Install a new color used for filling." | paintColor screen patternWord | paintColor _ self shadowColor ifNil:[aColor]. paintColor ifNil:[paintColor _ Color transparent]. paintColor isColor ifFalse:[ (paintColor isKindOf: InfiniteForm) ifFalse:[^self error:'Cannot install color']. ^port fillPattern: paintColor; combinationRule: Form paint]. "Okay, so paintColor really *is* a color" port sourceForm: nil. (paintColor isTranslucent) ifFalse:[ port fillPattern: paintColor. port combinationRule: Form paint. self depth = 8 ifTrue:[ port fillColor: (form balancedPatternFor: paintColor)]. ^self]. "paintColor is translucent color" self depth > 8 ifTrue:[ "BitBlt setup for alpha mapped transfer" port fillPattern: paintColor. self depth = 16 ifTrue:[port alphaBits: paintColor privateAlpha; combinationRule: 31] ifFalse:[port combinationRule: Form blend]. ^self]. "Can't represent actual transparency -- use stipple pattern" screen _ Color translucentMaskFor: paintColor alpha depth: self depth. patternWord _ form pixelWordFor: paintColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint ! ! !FormCanvas class methodsFor: 'instance creation' stamp: 'nk 7/4/2003 10:11'! extent: extent depth: depth origin: aPoint clipRect: aRectangle ^ self new setForm: (Form extent: extent depth: depth); setOrigin: aPoint clipRect: aRectangle; yourself! ! !FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'! test1 "FormCanvas test1" | canvas | canvas _ FormCanvas extent: 200@200. canvas fillColor: (Color black). canvas line: 10@10 to: 50@30 width: 1 color: (Color red). canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green). canvas point: 100@100 color: (Color black). canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: (Color cyan). canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta). canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan). canvas frameOval: ((40@80) corner: (61@121)) color: (Color blue). canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: (Color red alpha: 0.2). canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow). canvas showAt: 0@0. ! ! !FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:26'! test2 "FormCanvas test2" | baseCanvas p | baseCanvas _ FormCanvas extent: 200@200. p _ Sensor cursorPoint. [Sensor anyButtonPressed] whileFalse: [ baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas| canvas fillColor: Color white. canvas line: 10@10 to: 50@30 width: 1 color: Color red. canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. canvas point: 100@100 color: Color black. canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. canvas showAt: 0@0]]. ! ! !FormCanvas class methodsFor: 'testing' stamp: 'ar 12/31/2001 02:25'! test3 "FormCanvas test3" | baseCanvas | baseCanvas _ FormCanvas extent: 200@200. baseCanvas fillColor: Color white. baseCanvas translateBy: 10@10 during:[:canvas| canvas shadowColor: (Color black alpha: 0.5). canvas line: 10@10 to: 50@30 width: 1 color: Color red. canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. canvas point: 100@100 color: Color black. canvas drawString: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. canvas showAt: 0@0. ].! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 12/5/2003 23:00'! block "Allow the user to fill a rectangle with the gray tone and mode currently selected." | rectangle originRect | originRect := (Sensor cursorPoint grid: grid) extent: 2 @ 2. rectangle := Cursor corner showWhile: [originRect newRectFrom: [:f | f origin corner: (Sensor cursorPoint grid: grid)]]. rectangle isNil ifFalse: [sensor waitNoButton. Display fill: (rectangle intersect: view insetDisplayBox) rule: mode fillColor: color. hasUnsavedChanges contents: true.]! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 16:21'! curve "Conic-section specified by three points designated by: first point--press red button second point--release red button third point--click red button. The resultant curve on the display is displayed according to the current form and mode." | firstPoint secondPoint thirdPoint curve drawForm | "sensor noButtonPressed ifTrue: [^self]." firstPoint _ self cursorPoint. secondPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed]. thirdPoint _ self rubberBandFrom: secondPoint until: [sensor redButtonPressed]. Display depth > 1 ifTrue: [self deleteRubberBandFrom: secondPoint to: thirdPoint. self deleteRubberBandFrom: firstPoint to: secondPoint]. curve _ CurveFitter new. curve firstPoint: firstPoint. curve secondPoint: secondPoint. curve thirdPoint: thirdPoint. drawForm := form asFormOfDepth: Display depth. Display depth > 1 ifTrue: [drawForm mapColor: Color white to: Color transparent; mapColor: Color black to: color]. curve form: drawForm. curve displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]] ifFalse: [mode]) fillColor: (Display depth = 1 ifTrue: [color] ifFalse: [nil]). sensor waitNoButton. hasUnsavedChanges contents: true.! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 12/12/2003 15:51'! line "Line is specified by two points from the mouse: first point--press red button; second point--release red button. The resultant line is displayed according to the current form and mode." | firstPoint endPoint drawForm | drawForm := form asFormOfDepth: Display depth. Display depth > 1 ifTrue: [drawForm mapColor: Color white to: Color transparent; mapColor: Color black to: color]. firstPoint _ self cursorPoint. endPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed]. endPoint isNil ifTrue: [^self]. Display depth > 1 ifTrue: [self deleteRubberBandFrom: firstPoint to: endPoint.]. (Line from: firstPoint to: endPoint withForm: drawForm) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]] ifFalse: [mode]) fillColor: (Display depth = 1 ifTrue: [color] ifFalse: [nil]). hasUnsavedChanges contents: true.! ! !FormEditor methodsFor: 'editing tools' stamp: 'jm 6/30/1999 15:46'! newSourceForm "Allow the user to define a new source form for the FormEditor. Copying the source form onto the display is the primary graphical operation. Resets the tool to be repeatCopy." | dForm interiorPoint interiorColor | dForm _ Form fromUser: grid. "sourceForm must be only 1 bit deep" interiorPoint _ dForm extent // 2. interiorColor _ dForm colorAt: interiorPoint. form _ (dForm makeBWForm: interiorColor) reverse findShapeAroundSeedBlock: [:f | f pixelValueAt: interiorPoint put: 1]. form _ form trimBordersOfColor: Color white. tool _ previousTool! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 15:59'! repeatCopy "As long as the red button is pressed, copy the source form onto the display screen." | drawingWasChanged | drawingWasChanged := false. [sensor redButtonPressed] whileTrue: [(BitBlt current destForm: Display sourceForm: form halftoneForm: color combinationRule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]] ifFalse: [mode]) destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent clipRect: view insetDisplayBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF); copyBits. drawingWasChanged := true. ]. drawingWasChanged ifTrue: [hasUnsavedChanges contents: true.]! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 2/25/2001 21:36'! setColor: aColor "Set the mask (color) to aColor. Hacked to invoke color chooser if not B/W screen. Leaves the tool set in its previous state." self normalizeColor: (unNormalizedColor := Display depth > 1 ifTrue: [Color fromUser] ifFalse: [aColor]). tool _ previousTool! ! !FormEditor methodsFor: 'editing tools' stamp: 'BG 12/10/2003 16:00'! singleCopy "If the red button is clicked, copy the source form onto the display screen." (BitBlt destForm: Display sourceForm: form halftoneForm: color combinationRule: (Display depth > 1 ifTrue: [mode ~= Form erase ifTrue: [Form paint] ifFalse: [mode]] ifFalse: [mode]) destOrigin: self cursorPoint sourceOrigin: 0@0 extent: form extent clipRect: view insetDisplayBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF); copyBits. sensor waitNoButton. hasUnsavedChanges contents: true.! ! !FormEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 22:59'! accept "The edited information should now be accepted by the view." view updateDisplay. view accept. hasUnsavedChanges contents: false.! ! !FormEditor methodsFor: 'menu messages' stamp: 'BG 12/5/2003 22:59'! cancel "The edited information should be forgotten by the view." view cancel. hasUnsavedChanges contents: false.! ! !FormEditor methodsFor: 'private' stamp: 'BG 12/10/2003 17:02'! deleteRubberBandFrom: startPoint to: endPoint (Line from: startPoint to: endPoint withForm: form) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse fillColor: (Display depth = 1 ifTrue: [Color black] ifFalse: [Color gray]).! ! !FormEditor methodsFor: 'private' stamp: 'BG 12/10/2003 16:47'! rubberBandFrom: startPoint until: aBlock | endPoint previousEndPoint | previousEndPoint _ startPoint. [aBlock value] whileFalse: [(endPoint _ self cursorPoint) = previousEndPoint ifFalse: [(Line from: startPoint to: previousEndPoint withForm: form) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse fillColor: Color gray. (Line from: startPoint to: endPoint withForm: form) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse fillColor: Color gray. previousEndPoint _ endPoint]]. (Line from: startPoint to: previousEndPoint withForm: form) displayOn: Display at: 0 @ 0 clippingBox: view insetDisplayBox rule: Form reverse fillColor: (Display depth = 1 ifTrue: [Color gray] ifFalse: [Color black]). ^endPoint! ! !FormEditor methodsFor: 'private' stamp: 'BG 12/5/2003 22:58'! setVariables tool _ #repeatCopy. previousTool _ tool. grid _ 1 @ 1. togglegrid _ 8 @ 8. xgridOn _ false. ygridOn _ false. mode _ Form over. form _ Form extent: 8 @ 8. form fillBlack. unNormalizedColor _ color _ Color black. hasUnsavedChanges := ValueHolder new contents: false. ! ! !FormEditor methodsFor: 'private' stamp: 'BG 12/12/2003 15:50'! trackFormUntil: aBlock | previousPoint cursorPoint displayForm | previousPoint _ self cursorPoint. displayForm := Form extent: form extent depth: form depth. displayForm copy: (0 @ 0 extent: form extent) from: form to: 0 @ 0 rule: Form over. Display depth > 1 ifTrue: [displayForm reverse]. displayForm displayOn: Display at: previousPoint rule: Form reverse. [aBlock value] whileFalse: [cursorPoint _ self cursorPoint. (FlashCursor or: [cursorPoint ~= previousPoint]) ifTrue: [displayForm displayOn: Display at: previousPoint rule: Form reverse. displayForm displayOn: Display at: cursorPoint rule: Form reverse. previousPoint _ cursorPoint]]. displayForm displayOn: Display at: previousPoint rule: Form reverse. ^previousPoint! ! !FormEditor methodsFor: 'window support' stamp: 'BG 12/5/2003 23:23'! okToChange ^hasUnsavedChanges contents not ifFalse: [PopUpMenu confirm: 'This drawing was not saved.\Is it OK to close this window?' withCRs ] ifTrue: [true] ! ! !FormEditor commentStamp: 'BG 12/5/2003 22:40' prior: 0! I represent the basic editor for creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. I am a kind of MouseMenuController that creates a yellow button menu for accepting and canceling edits. My instances give up control if the cursor is outside the FormView or if a key on the keyboard is pressed. The form to be edited is stored in instance variable model. The instance variable form references the paint brush.! !FormEditor class methodsFor: 'examples' stamp: 'BG 12/5/2003 22:39'! newForm "Create an instance of me on a new form at a location designated by the user. " (Form extent: 400 @ 200 depth: Display depth) fillWhite; edit "FormEditor newForm"! ! !FormEditor class methodsFor: 'private' stamp: 'BG 12/5/2003 23:18'! createOnForm: aForm "Create a StandardSystemView for a FormEditor on the form aForm." | formView formEditor menuView aView topView extent topViewBorder | topViewBorder _ 2. formView _ FormHolderView new model: aForm. formEditor _ formView controller. menuView _ FormMenuView new makeFormEditorMenu model: formEditor. formEditor model: aForm. aView _ View new. aView model: aForm. aView addSubView: formView. aView addSubView: menuView align: menuView viewport topCenter with: formView viewport bottomCenter + (0@16). aView window: ((formView viewport merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))) expandBy: (0@topViewBorder corner: 0@0)). topView _ "ColorSystemView" FormEditorView new. topView model: formEditor. topView backgroundColor: #veryLightGray. topView addSubView: aView. topView label: 'Form Editor'. topView borderWidth: topViewBorder. extent _ topView viewport extent. topView minimumSize: extent. topView maximumSize: extent. ^topView! ! !FormInspectView class methodsFor: 'instance creation' stamp: 'sd 5/11/2003 21:36'! openOn: aFormDictionary withLabel: aLabel "open a graphical dictionary in a window having the label aLabel. aFormDictionary should be a dictionary containing as value a form." ^ DictionaryInspector openOn: aFormDictionary withEvalPane: true withLabel: aLabel valueViewClass: self! ! !FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:22'! makeButton: index | buttonCache button | buttonCache _ (FormButtons at: index) shallowCopy. buttonCache form: (FormButtons at: index) form copy. button _ Button newOff. button onAction: [model changeTool: buttonCache value]. self makeViews: buttonCache for: button. ! ! !FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'! makeColorConnections: indexInterval | connector buttonCache button aSwitchView | connector _ Object new. "a dummy model for connecting dependents" indexInterval do: [:index | buttonCache _ (FormButtons at: index) shallowCopy. buttonCache form: (FormButtons at: index) form copy. buttonCache initialState = #true ifTrue: [button _ OneOnSwitch newOn] ifFalse: [button _ OneOnSwitch newOff]. button onAction: [model changeTool: buttonCache value]. button connection: connector. aSwitchView _ self makeViews: buttonCache for: button. aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1; action: #turnOn]. aSwitchView borderWidth: 1. ! ! !FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'! makeConnections: indexInterval | connector buttonCache button aSwitchView | connector _ Object new. "a dummy model for connecting dependents." indexInterval do: [:index | buttonCache _ (FormButtons at: index) shallowCopy. buttonCache form: (FormButtons at: index) form copy. buttonCache initialState = #true ifTrue: [button _ OneOnSwitch newOn] ifFalse: [button _ OneOnSwitch newOff]. button onAction: [model changeTool: buttonCache value]. button connection: connector. aSwitchView _ self makeViews: buttonCache for: button. aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1; action: #turnOn]. aSwitchView borderWidth: 1. ! ! !FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 15:24'! makeGridSwitch: index | buttonCache button | buttonCache _ FormButtons at: index. buttonCache form: (FormButtons at: index) form copy. buttonCache initialState = #true ifTrue: [button _ Switch newOn] ifFalse: [button _ Switch newOff]. button onAction: [model changeTool: buttonCache value]. button offAction: [model changeTool: buttonCache value]. self makeViews: buttonCache for: button. ! ! !FormMenuView methodsFor: 'private' stamp: 'BG 12/4/2003 14:23'! makeSwitch: index | buttonCache button | buttonCache _ (FormButtons at: index) shallowCopy. buttonCache form: (FormButtons at: index) form copy. buttonCache initialState = #true ifTrue: [button _ Switch newOn] ifFalse: [button _ Switch newOff]. button onAction: [model changeTool: buttonCache value]. self makeViews: buttonCache for: button. ! ! !FormMenuView class methodsFor: 'class initialization' stamp: 'gk 2/28/2005 16:38'! initialize "The icons for the menu are typically stored on files. In order to avoid reading them every time, they are stored in a collection in a class variable, along with their offset, tool value, and initial visual state (on or off)." "FormMenuView initialize" | offsets keys states names button | offsets _ OrderedCollection new: 21. #(0 64 96 128 160 192 256 288 320 352 420) do: [:i | offsets addLast: i@0]. "First row" #(0 64 96 128 160 192 256 304 352 420) do: [:i | offsets addLast: i@48]. "Second row" offsets _ offsets asArray. keys _ #($a $s $d $f $g $h $j $k $l $; $' $z $x $c $v $b $n $m $, $. $/ ). "Keyboard" states _ #( #false #false #true #false #false #false #true #false #false #false #false #false #false #false #false #false #true #false #false #false #false). "Initial button states" names _ #('select.form' 'singlecopy.form' 'repeatcopy.form' 'line.form' 'curve.form' 'block.form' 'over.form' 'under.form' 'reverse.form' 'erase.form' 'in.form' 'magnify.form' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form' 'xgrid.form' 'ygrid.form' 'togglegrids.form' 'out.form'). "Files of button images" FormButtons _ OrderedCollection new. 1 to: 21 do: [:index | button _ FormButtonCache new. button form: (Form fromFileNamed: (names at: index)). button offset: (offsets at: index). button value: (keys at: index). button initialState: (states at: index). FormButtons addLast: button]. SpecialBorderForm _ Form fromFileNamed: 'specialborderform.form'. BorderForm _ Form fromFileNamed: 'borderform.form'. ! ! !FormMenuView class methodsFor: 'accessing' stamp: 'BG 12/4/2003 12:11'! formButtons ^FormButtons! ! !FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! locator ^locator! ! !FormStub methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:02'! locator: aString locator _ aString! ! !FormStub methodsFor: 'fileIn/Out' stamp: 'ar 2/27/2001 21:36'! objectForDataStream: refStream "Force me into outPointers so that I get notified about startup" refStream replace: self with: self. ^self! ! !FormView class methodsFor: 'examples' stamp: 'BG 12/5/2003 14:45'! open: aForm named: aString "FormView open: ((Form extent: 100@100) borderWidth: 1) named: 'Squeak' " "Open a window whose model is aForm and whose label is aString." | topView aView | topView _ StandardSystemView new. topView model: aForm. topView label: aString. topView minimumSize: aForm extent; maximumSize: aForm extent. aView _ FormView new. aView model: aForm. aView window: (aForm boundingBox expandBy: 2). aView borderWidthLeft: 2 right: 2 top: 2 bottom: 2. topView addSubView: aView. topView controller open! ! !Fraction methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'! reciprocal "Refer to the comment in Number|reciprocal." #Numeric. "Changed 200/01/19 For ANSI support." numerator = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. numerator = 1 ifTrue: [^ denominator]. numerator = -1 ifTrue: [^ denominator negated]. ^ Fraction numerator: denominator denominator: numerator! ! !Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'! adaptToComplex: rcvr andSend: selector "If I am involved in arithmetic with a Complex number, convert me to a Complex number." ^ rcvr perform: selector with: self asComplex! ! !Fraction methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector "Convert receiverScaledDecimal to a Fraction and do the arithmetic. receiverScaledDecimal arithmeticOpSelector self." #Numeric. "add 200/01/19 For ScaledDecimal support." ^ receiverScaledDecimal asFraction perform: arithmeticOpSelector with: self! ! !Fraction methodsFor: 'converting' stamp: 'mk 10/27/2003 18:13'! asComplex "Answer a Complex number that represents value of the the receiver." ^ Complex real: self imaginary: 0! ! !Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 12:56'! printOn: aStream base: base aStream nextPut: $(. numerator printOn: aStream base: base. aStream nextPut: $/. denominator printOn: aStream base: base. aStream nextPut: $). ! ! !Fraction methodsFor: 'printing' stamp: 'laza 3/29/2004 13:25'! storeOn: aStream base: base aStream nextPut: $(. numerator storeOn: aStream base: base. aStream nextPut: $/. denominator storeOn: aStream base: base. aStream nextPut: $). ! ! !Fraction commentStamp: '' prior: 0! Fraction provides methods for dealing with fractions like 1/3 as fractions (not as 0.33333...). All public arithmetic operations answer reduced fractions (see examples). instance variables: 'numerator denominator ' Examples: (note the parentheses required to get the right answers in Smalltalk and Squeak): (2/3) + (2/3) (2/3) + (1/2) "answers shows the reduced fraction" (2/3) raisedToInteger: 5 "fractions also can have exponents" ! !Fraction class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'! one #Numeric. "add 200/01/19 For protocol support." ^ self numerator: 1 denominator: 1! ! !FractionTest methodsFor: 'testing' stamp: 'sd 3/4/2004 21:13'! testDegreeCos "self run: #testDegreeCos" self shouldnt: [ (4/3) degreeCos] raise: Error. self assert: (1/3) degreeCos printString = '0.999983076857744'! ! !FractionTest methodsFor: 'testing' stamp: 'sd 3/5/2004 14:54'! testDegreeSin "self run: #testDegreeSin" self shouldnt: [ (4/3) degreeSin] raise: Error. self assert: (1/3) degreeSin printString = '0.005817731354993834'.! ! !FractionTest methodsFor: 'testing-printing' stamp: 'laza 3/30/2004 09:28'! testFractionPrinting self assert: (353/359) printString = '(353/359)'. self assert: ((2/3) printStringBase: 2) = '(10/11)'. self assert: ((2/3) storeStringBase: 2) = '(2r10/2r11)'. self assert: ((5/7) printStringBase: 3) = '(12/21)'. self assert: ((5/7) storeStringBase: 3) = '(3r12/3r21)'. self assert: ((11/13) printStringBase: 4) = '(23/31)'. self assert: ((11/13) storeStringBase: 4) = '(4r23/4r31)'. self assert: ((17/19) printStringBase: 5) = '(32/34)'. self assert: ((17/19) storeStringBase: 5) = '(5r32/5r34)'. self assert: ((23/29) printStringBase: 6) = '(35/45)'. self assert: ((23/29) storeStringBase: 6) = '(6r35/6r45)'. self assert: ((31/37) printStringBase: 7) = '(43/52)'. self assert: ((31/37) storeStringBase: 7) = '(7r43/7r52)'. self assert: ((41/43) printStringBase: 8) = '(51/53)'. self assert: ((41/43) storeStringBase: 8) = '(8r51/8r53)'. self assert: ((47/53) printStringBase: 9) = '(52/58)'. self assert: ((47/53) storeStringBase: 9) = '(9r52/9r58)'. self assert: ((59/61) printStringBase: 10) = '(59/61)'. self assert: ((59/61) storeStringBase: 10) = '(59/61)'. self assert: ((67/71) printStringBase: 11) = '(61/65)'. self assert: ((67/71) storeStringBase: 11) = '(11r61/11r65)'. self assert: ((73/79) printStringBase: 12) = '(61/67)'. self assert: ((73/79) storeStringBase: 12) = '(12r61/12r67)'. self assert: ((83/89) printStringBase: 13) = '(65/6B)'. self assert: ((83/89) storeStringBase: 13) = '(13r65/13r6B)'. self assert: ((97/101) printStringBase: 14) = '(6D/73)'. self assert: ((97/101) storeStringBase: 14) = '(14r6D/14r73)'. self assert: ((103/107) printStringBase: 15) = '(6D/72)'. self assert: ((103/107) storeStringBase: 15) = '(15r6D/15r72)'. self assert: ((109/113) printStringBase: 16) = '(6D/71)'. self assert: ((109/113) storeStringBase: 16) = '(16r6D/16r71)'. self assert: ((127/131) printStringBase: 17) = '(78/7C)'. self assert: ((127/131) storeStringBase: 17) = '(17r78/17r7C)'. self assert: ((137/139) printStringBase: 18) = '(7B/7D)'. self assert: ((137/139) storeStringBase: 18) = '(18r7B/18r7D)'. self assert: ((149/151) printStringBase: 19) = '(7G/7I)'. self assert: ((149/151) storeStringBase: 19) = '(19r7G/19r7I)'. self assert: ((157/163) printStringBase: 20) = '(7H/83)'. self assert: ((157/163) storeStringBase: 20) = '(20r7H/20r83)'. self assert: ((167/173) printStringBase: 21) = '(7K/85)'. self assert: ((167/173) storeStringBase: 21) = '(21r7K/21r85)'. self assert: ((179/181) printStringBase: 22) = '(83/85)'. self assert: ((179/181) storeStringBase: 22) = '(22r83/22r85)'. self assert: ((191/193) printStringBase: 23) = '(87/89)'. self assert: ((191/193) storeStringBase: 23) = '(23r87/23r89)'. self assert: ((197/199) printStringBase: 24) = '(85/87)'. self assert: ((197/199) storeStringBase: 24) = '(24r85/24r87)'. self assert: ((211/223) printStringBase: 25) = '(8B/8N)'. self assert: ((211/223) storeStringBase: 25) = '(25r8B/25r8N)'. self assert: ((227/229) printStringBase: 26) = '(8J/8L)'. self assert: ((227/229) storeStringBase: 26) = '(26r8J/26r8L)'. self assert: ((233/239) printStringBase: 27) = '(8H/8N)'. self assert: ((233/239) storeStringBase: 27) = '(27r8H/27r8N)'. self assert: ((241/251) printStringBase: 28) = '(8H/8R)'. self assert: ((241/251) storeStringBase: 28) = '(28r8H/28r8R)'. self assert: ((257/263) printStringBase: 29) = '(8P/92)'. self assert: ((257/263) storeStringBase: 29) = '(29r8P/29r92)'. self assert: ((269/271) printStringBase: 30) = '(8T/91)'. self assert: ((269/271) storeStringBase: 30) = '(30r8T/30r91)'. self assert: ((277/281) printStringBase: 31) = '(8T/92)'. self assert: ((277/281) storeStringBase: 31) = '(31r8T/31r92)'. self assert: ((283/293) printStringBase: 32) = '(8R/95)'. self assert: ((283/293) storeStringBase: 32) = '(32r8R/32r95)'. self assert: ((307/311) printStringBase: 33) = '(9A/9E)'. self assert: ((307/311) storeStringBase: 33) = '(33r9A/33r9E)'. self assert: ((313/317) printStringBase: 34) = '(97/9B)'. self assert: ((313/317) storeStringBase: 34) = '(34r97/34r9B)'. self assert: ((331/337) printStringBase: 35) = '(9G/9M)'. self assert: ((331/337) storeStringBase: 35) = '(35r9G/35r9M)'. self assert: ((347/349) printStringBase: 36) = '(9N/9P)'. self assert: ((347/349) storeStringBase: 36) = '(36r9N/36r9P)'. self assert: ((-2/3) printStringBase: 2) = '(-10/11)'. self assert: ((-2/3) storeStringBase: 2) = '(-2r10/2r11)'. self assert: ((5/-7) printStringBase: 3) = '(-12/21)'. self assert: ((5/-7) storeStringBase: 3) = '(-3r12/3r21)'. ! ! !FrameRateMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" lastDisplayTime _ 0. framesSinceLastDisplay _ 0! ! !FrameRateMorph methodsFor: 'parts bin' stamp: 'sw 7/19/2001 13:39'! initializeToStandAlone "Initialize the receiver as a stand-alone entity" super initializeToStandAlone. self color: Color blue. self step! ! !FrameRateMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:49'! descriptionForPartsBin ^ self partName: 'FrameRate' categories: #('Useful') documentation: 'A readout that allows you to monitor the frame rate of your system'! ! !FrameRateMorph class methodsFor: 'scripting' stamp: 'sw 6/13/2001 00:57'! authoringPrototype "Answer a morph representing a prototypical instance of the receiver" | aMorph | aMorph _ self new. aMorph color: Color blue. aMorph step. ^ aMorph! ! !FrameRateMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:05'! initialize self registerInFlapsRegistry. ! ! !FrameRateMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:06'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(FrameRateMorph authoringPrototype 'Frame Rate' 'An indicator of how fast your system is running') forFlapNamed: 'Widgets']! ! !FrameRateMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:36'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !FreeTranslation class methodsFor: 'translation' stamp: 'yo 8/11/2003 21:12'! extract: aMimeDoc | pageSource str | "Extract the translated text from the web page" (aMimeDoc content beginsWith: 'error') ifTrue: [^ aMimeDoc content]. pageSource _ aMimeDoc content. "brute force way to pull out the result" str _ ReadStream on: pageSource. str match: 'Translation Results by Transparent Language'. str match: '

'. ^ str upToAll: '

'! ! !FreeTranslation class methodsFor: 'translation' stamp: 'gm 2/22/2003 18:57'! translatePanel: buttonPlayer fromTo: normalDirection | ow fromTM toTM fromLang toLang tt doc answer width | "Gather up all the info I need from the morphs in the button's owner and do the translation. Insert the results in a TextMorph. Use www.freeTranslation.com Refresh the banner ad. TextMorph with 'from' in the title is starting text. PopUpChoiceMorph with 'from' in the title is the starting language. TextMorph with 'from' in the title is place to put the answer. PopUpChoiceMorph with 'from' in the title is the target language. If normalDirection is false, translate the other direction." ow _ buttonPlayer costume ownerThatIsA: PasteUpMorph. ow allMorphs do: [:mm | (mm isTextMorph) ifTrue: [ (mm knownName asString includesSubString: 'from') ifTrue: [ fromTM _ mm]. (mm knownName asString includesSubString: 'to') ifTrue: [ toTM _ mm]]. (mm isKindOf: PopUpChoiceMorph) ifTrue: [ (mm knownName asString includesSubString: 'from') ifTrue: [ fromLang _ mm contents asString]. (mm owner knownName asString includesSubString: 'from') ifTrue: [ fromLang _ mm contents asString]. (mm knownName asString includesSubString: 'to') ifTrue: [ toLang _ mm contents asString]. (mm owner knownName asString includesSubString: 'to') ifTrue: [ toLang _ mm contents asString]]]. normalDirection ifFalse: ["switch" tt _ fromTM. fromTM _ toTM. toTM _ tt. tt _ fromLang. fromLang _ toLang. toLang _ tt]. Cursor wait showWhile: [ doc _ self translate: fromTM contents asString from: fromLang to: toLang. answer _ self extract: doc]. "pull out the translated text" width _ toTM width. toTM contents: answer wrappedTo: width. toTM changed.! ! !FreeTranslation class methodsFor: 'scamper' stamp: 'ads 4/1/2003 19:24'! openScamperOn: currentSelection "Submit the string to the translation server at www.freetranslation.com. Ask it to translate from (Preferences parameterAt: #languageTranslateFrom) to (Preferences parameterAt: #languageTranslateTo). Display the results in a Scamper window, reusing the previous one if possible." | inputs scamperWindow from to | currentSelection size >= 10000 ifTrue: [^ self inform: 'Text selection is too long.']. from _ Preferences parameterAt: #languageTranslateFrom ifAbsentPut: ['English']. to _ Preferences parameterAt: #languageTranslateTo ifAbsentPut: ['German']. from = to ifTrue: [^ self inform: 'You asked to translate from ', from, ' to ', to, '.\' withCRs, 'Use "choose language" to set these.']. inputs _ Dictionary new. inputs at: 'SrcText' put: (Array with: currentSelection). inputs at: 'Sequence' put: #('core'). inputs at: 'Mode' put: #('html'). inputs at: 'template' put: #('TextResult2.htm'). inputs at: 'Language' put: (Array with: from, '/', to). scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: 'http://ets.freetranslation.com'. scamperWindow model submitFormWithInputs: inputs url: 'http://ets.freetranslation.com:5081' asUrl method: 'post'. scamperWindow activate. ! ! !FtpUrl methodsFor: 'downloading' stamp: 'mir 8/5/2004 11:55'! downloadUrl "Returns a http download url for the location defined by this url." | ans | ans _ WriteStream on: String new. ans nextPutAll: self schemeName. ans nextPutAll: '://'. ans nextPutAll: self authority. port ifNotNil: [ans nextPut: $:; print: port]. path do: [ :pathElem | ans nextPut: $/. ans nextPutAll: pathElem encodeForHTTP. ]. self query isNil ifFalse: [ ans nextPut: $?. ans nextPutAll: self query. ]. self fragment isNil ifFalse: [ ans nextPut: $#. ans nextPutAll: self fragment encodeForHTTP. ]. ^ans contents! ! !FtpUrl methodsFor: 'downloading' stamp: 'mir 6/27/2003 19:42'! retrieveContents "currently assumes directories end in /, and things that don't end in / are files. Also, doesn't handle errors real well...." | server contents pathString listing auth idx fileName serverName userName password | pathString _ self pathString. pathString _ pathString copyFrom: 2 to: pathString size. "remove the leading /" pathString last = $/ ifTrue:["directory?!!" fileName _ nil. ] ifFalse:[ fileName _ pathString copyFrom: (pathString lastIndexOf: $/)+1 to: pathString size. pathString _ pathString copyFrom: 1 to: (pathString lastIndexOf: $/) - 1. ]. auth _ self authority. idx _ auth indexOf: $@. idx > 0 ifTrue:[ serverName _ (auth copyFrom: idx+1 to: auth size). userName _ (auth copyFrom: 1 to: idx-1). password _ nil. ] ifFalse:[ serverName _ auth. userName _ 'anonymous'. password _ 'SqueakUser'. ]. server _ ServerDirectory servers detect:[:s| s isTypeFTP and:[s server asLowercase = serverName asLowercase]] ifNone:[nil]. server ifNil:[ server _ ServerDirectory new. server server: serverName. ] ifNotNil:[server _ server copy reset]. server user: userName. password ifNotNil:[server password: password]. server directory: pathString. fileName == nil ifFalse:[ "a file" contents _ (server getFileNamed: fileName). server sleep. ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: contents]. "a directory?" listing _ String streamContents: [ :stream | stream nextPutAll: '', self pathString, ''; cr. stream nextPutAll: '

Listing for ', self pathString, '

'; cr. stream nextPutAll: '
    '; cr. server entries do: [ :entry | stream nextPutAll: '
  • '; nextPutAll: ''; nextPutAll: entry name; nextPutAll: ''; cr ] ]. server sleep. ^MIMEDocument contentType: 'text/html' content: listing! ! !FtpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:07'! hasRemoteContents "Return true if the receiver describes some remotely accessible content. Typically, this should only return if we could retrieve the contents on an arbitrary place in the outside world using a standard browser. In other words: If you can get to it from the next Internet Cafe, return true, else return false." ^true! ! !FtpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! a reference to a file which may be downloaded by anonymous ftp . TODO: use the username and password, if specified ! !FullVocabulary methodsFor: 'initialization' stamp: 'sw 9/25/2001 21:52'! initialize "Initialize the receiver (automatically called when instances are created via 'new') Vocabulary initialize " super initialize. vocabularyName _ #Object. self documentation: '"Object" is all-encompassing vocabulary that embraces all methods understood by an object'. self rigAFewCategories! ! !FullVocabulary methodsFor: 'initialization' stamp: 'sw 9/13/2001 23:26'! rigAFewCategories "Formerly used to rig generic categories, now seemingly disfunctional and in abeyance" | aMethodCategory | true ifTrue: [^ self]. self flag: #deferred. "Vocabulary fullVocabulary rigAFewCategories " #( (accessing 'Generally holds methods to read and write instance variables') (initialization 'messages typically sent when an object is created, to set up its initial state')) do: [:pair | aMethodCategory _ ElementCategory new categoryName: pair first. aMethodCategory documentation: pair second. self addCategory: aMethodCategory]! ! !FullVocabulary methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(1.0 0.26 0.98) ! ! !FullVocabulary methodsFor: 'queries'! categoriesContaining: aSelector forClass: aTargetClass "Answer a list of category names (all symbols) of categories that contain the given selector for the target object. Initially, this just returns one." | classDefiningSelector catName | classDefiningSelector _ aTargetClass whichClassIncludesSelector: aSelector. classDefiningSelector ifNil: [^ OrderedCollection new]. catName _ classDefiningSelector whichCategoryIncludesSelector: aSelector. ^ OrderedCollection with: catName! ! !FullVocabulary methodsFor: 'queries'! categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: targetClass "Answer the name of a category, from among the provided categoryNames, which defines the selector for the given class. Here, if the category designated by the implementing class is acceptable it is the one returned" | aClass catName result | (aClass _ targetClass whichClassIncludesSelector: aSelector) ifNotNil: [(categoryNames includes: (catName _ aClass whichCategoryIncludesSelector: aSelector)) ifTrue: [catName ~~ #'as yet unclassified' ifTrue: [^ catName]]]. result _ super categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: aClass. ^ result ifNil: [#'as yet unclassified']! ! !FullVocabulary methodsFor: 'queries' stamp: 'sw 3/20/2001 15:42'! includesDefinitionForSelector: aSelector "Answer whether the given selector is known to the vocabulary. Unsent at the moment, may disappear." ^ true! ! !FullVocabulary methodsFor: 'queries' stamp: 'sw 9/27/2001 03:28'! representsAType "Answer whether this vocabulary represents an end-user-sensible data type" ^ false! ! !FunctionComponent methodsFor: 'button' stamp: 'dgd 2/22/2003 14:25'! fire | arguments newValue | outputSelector ifNil: [^outputValue := nil]. functionSelector ifNil: [^outputValue := nil]. arguments := inputSelectors collect: [:s | s ifNil: [nil] ifNotNil: [model perform: s]]. newValue := (arguments findFirst: [:a | a isNil]) = 0 ifTrue: [model perform: functionSelector withArguments: arguments] ifFalse: [nil]. newValue = outputValue ifFalse: [model perform: outputSelector with: newValue. outputValue := newValue]! ! !FunctionComponent methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:45'! addCustomMenuItems: aMenu hand: aHandMorph "Add custom menu items" super addCustomMenuItems: aMenu hand: aHandMorph. aMenu add: 'add pin' translated target: self selector: #addPin. ! ! !GB2312 commentStamp: 'yo 10/19/2004 19:52' prior: 0! This class represents the domestic character encoding called GB 2312 used for simplified Chinese. ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:50'! compoundTextSequence ^ CompoundTextSequence ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:50'! initialize " GB2312 initialize " CompoundTextSequence _ String streamContents: [:stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $A]. ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading _ char leadingChar. value _ char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value _ value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:51'! leadingChar ^ 2. ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. (state g0Leading ~= self leadingChar) ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: CompoundTextSequence. ]. c1 _ ascii // 94 + 16r21. c2 _ ascii \\ 94 + 16r21. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2). ! ! !GB2312 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable gb2312Table. ! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:43'! delay: aNumberOrNil "Set delay for next image in hundredth (1/100) of seconds" delay := aNumberOrNil! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:39'! loopCount: aNumber "Set looping. This must be done before any image is written!!" loopCount := aNumber! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:18'! nextImage "Read in the next GIF image from the stream. Read it all into memory first for speed." | f thisImageColorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: (stream contentsOfEntireFile))]. localColorTable _ nil. self readHeader. f _ self readBody. self close. f == nil ifTrue: [^ self error: 'corrupt GIF file']. thisImageColorTable _ localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [ transparentIndex + 1 > thisImageColorTable size ifTrue: [ thisImageColorTable _ thisImageColorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. thisImageColorTable at: transparentIndex + 1 put: Color transparent ]. f colors: thisImageColorTable. ^ f ! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'nk 4/17/2004 19:44'! nextPutImage: aForm | f newF | aForm unhibernate. f _ aForm colorReduced. "minimize depth" f depth > 8 ifTrue: [ "Not enough color space; do it the hard way." f _ f asFormOfDepth: 8]. f depth < 8 ifTrue: [ "writeBitData: expects depth of 8" newF _ f class extent: f extent depth: 8. (f isColorForm) ifTrue: [ newF copyBits: f boundingBox from: f at: 0@0 clippingBox: f boundingBox rule: Form over fillColor: nil map: nil. newF colors: f colors] ifFalse: [f displayOn: newF]. f _ newF]. (f isColorForm) ifTrue: [ (f colorsUsed includes: Color transparent) ifTrue: [ transparentIndex _ (f colors indexOf: Color transparent) - 1]] ifFalse: [transparentIndex _ nil]. width _ f width. height _ f height. bitsPerPixel _ f depth. colorPalette _ f colormapIfNeededForDepth: 32. interlace _ false. self writeHeader. self writeBitData: f bits. ! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:21'! writeBitData: bits "using modified Lempel-Ziv Welch algorithm." | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch | pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ width * 8 + 31 // 32 * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ WriteStream on: (ByteArray new: 256). maxBits _ 12. maxMaxCode _ 1 bitShift: maxBits. tSize _ 5003. prefixTable _ Array new: tSize. suffixTable _ Array new: tSize. initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel]. self nextPut: initCodeSize. self setParameters: initCodeSize. tShift _ 0. fCode _ tSize. [fCode < 65536] whileTrue: [tShift _ tShift + 1. fCode _ fCode * 2]. tShift _ 8 - tShift. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self writeCodeAndCheckCodeSize: clearCode. ent _ self readPixelFrom: bits. [(pixel _ self readPixelFrom: bits) == nil] whileFalse: [ fCode _ (pixel bitShift: maxBits) + ent. index _ ((pixel bitShift: tShift) bitXor: ent) + 1. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index] ifFalse: [nomatch _ true. (suffixTable at: index) >= 0 ifTrue: [disp _ tSize - index + 1. index = 1 ifTrue: [disp _ 1]. "probe" [(index _ index - disp) < 1 ifTrue: [index _ index + tSize]. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index. nomatch _ false. "continue whileFalse:"]. nomatch and: [(suffixTable at: index) > 0]] whileTrue: ["probe"]]. "nomatch" nomatch ifTrue: [self writeCodeAndCheckCodeSize: ent. ent _ pixel. freeCode < maxMaxCode ifTrue: [prefixTable at: index put: freeCode. suffixTable at: index put: fCode. freeCode _ freeCode + 1] ifFalse: [self writeCodeAndCheckCodeSize: clearCode. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self setParameters: initCodeSize]]]]. prefixTable _ suffixTable _ nil. self writeCodeAndCheckCodeSize: ent. self writeCodeAndCheckCodeSize: eoiCode. self flushCode. self nextPut: 0. "zero-length packet" ! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:38'! writeHeader | byte | stream position = 0 ifTrue: [ "For first image only" self nextPutAll: 'GIF89a' asByteArray. self writeWord: width. "Screen Width" self writeWord: height. "Screen Height" byte _ 16r80. "has color map" byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5). "color resolution" byte _ byte bitOr: bitsPerPixel - 1. "bits per pixel" self nextPut: byte. self nextPut: 0. "background color." self nextPut: 0. "reserved" colorPalette do: [:pixelValue | self nextPut: ((pixelValue bitShift: -16) bitAnd: 255); nextPut: ((pixelValue bitShift: -8) bitAnd: 255); nextPut: (pixelValue bitAnd: 255)]. loopCount notNil ifTrue: [ "Write a Netscape loop chunk" self nextPut: Extension. self nextPutAll: #(255 11 78 69 84 83 67 65 80 69 50 46 48 3 1) asByteArray. self writeWord: loopCount. self nextPut: 0]]. delay notNil | transparentIndex notNil ifTrue: [ self nextPut: Extension; nextPutAll: #(16rF9 4) asByteArray; nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [9]); writeWord: (delay isNil ifTrue: [0] ifFalse: [delay]); nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [transparentIndex]); nextPut: 0]. self nextPut: ImageSeparator. self writeWord: 0. "Image Left" self writeWord: 0. "Image Top" self writeWord: width. "Image Width" self writeWord: height. "Image Height" byte _ interlace ifTrue: [16r40] ifFalse: [0]. self nextPut: byte. ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:19'! readBitData "using modified Lempel-Ziv Welch algorithm." | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | maxOutCodes _ 4096. offset := self readWord@self readWord. "Image Left@Image Top" width _ self readWord. height _ self readWord. "--- Local Color Table Flag 1 Bit Interlace Flag 1 Bit Sort Flag 1 Bit Reserved 2 Bits Size of Local Color Table 3 Bits ----" packedBits _ self next. interlace _ (packedBits bitAnd: 16r40) ~= 0. hasLocalColor _ (packedBits bitAnd: 16r80) ~= 0. localColorSize _ 1 bitShift: ((packedBits bitAnd: 16r7) + 1). hasLocalColor ifTrue: [localColorTable _ self readColorTable: localColorSize]. pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ ((width + 3) // 4) * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ ReadStream on: ByteArray new. outCodes _ ByteArray new: maxOutCodes + 1. outCount _ 0. bitMask _ (1 bitShift: bitsPerPixel) - 1. prefixTable _ Array new: 4096. suffixTable _ Array new: 4096. initCodeSize _ self next. self setParameters: initCodeSize. bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep']. bytes _ ByteArray new: rowByteSize * height. [(code _ self readCode) = eoiCode] whileFalse: [code = clearCode ifTrue: [self setParameters: initCodeSize. curCode _ oldCode _ code _ self readCode. finChar _ curCode bitAnd: bitMask. "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!? tk 6/24/97 20:16" xpos = 0 ifTrue: [ ypos < height ifTrue: [ bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]] ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]. self updatePixelPosition] ifFalse: [curCode _ inCode _ code. curCode >= freeCode ifTrue: [curCode _ oldCode. outCodes at: (outCount _ outCount + 1) put: finChar]. [curCode > bitMask] whileTrue: [outCount > maxOutCodes ifTrue: [^self error: 'corrupt GIF file (OutCount)']. outCodes at: (outCount _ outCount + 1) put: (suffixTable at: curCode + 1). curCode _ prefixTable at: curCode + 1]. finChar _ curCode bitAnd: bitMask. outCodes at: (outCount _ outCount + 1) put: finChar. i _ outCount. [i > 0] whileTrue: ["self writePixel: (outCodes at: i) to: bits" bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i). self updatePixelPosition. i _ i - 1]. outCount _ 0. prefixTable at: freeCode + 1 put: oldCode. suffixTable at: freeCode + 1 put: finChar. oldCode _ inCode. freeCode _ freeCode + 1. self checkCodeSize]]. prefixTable _ suffixTable _ nil. f _ ColorForm extent: width@height depth: 8. f bits copyFromByteArray: bytes. "Squeak can handle depths 1, 2, 4, and 8" bitsPerPixel > 4 ifTrue: [^ f]. "reduce depth to save space" c _ ColorForm extent: width@height depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]). f displayOn: c. ^ c ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'KLC 1/25/2004 14:04'! readBody "Read the GIF blocks. Modified to return a form. " | form extype block blocksize packedFields delay1 | form _ nil. [stream atEnd] whileFalse: [ block _ self next. block = Terminator ifTrue: [^ form]. block = ImageSeparator ifTrue: [ form isNil ifTrue: [form _ self readBitData] ifFalse: [self skipBitData]. ] ifFalse: [ block = Extension ifFalse: [^ form "^ self error: 'Unknown block type'"]. "Extension block" extype _ self next. "extension type" extype = 16rF9 ifTrue: [ "graphics control" self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. "==== Reserved 3 Bits Disposal Method 3 Bits User Input Flag 1 Bit Transparent Color Flag 1 Bit ===" packedFields _ self next. delay1 := self next. "delay time 1" delay := (self next*256 + delay1) *10. "delay time 2" transparentIndex _ self next. (packedFields bitAnd: 1) = 0 ifTrue: [transparentIndex _ nil]. self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. ] ifFalse: [ "Skip blocks" [(blocksize _ self next) > 0] whileTrue: [ "Read the block and ignore it and eat the block terminator" self next: blocksize]]]]! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:48'! readColorTable: numberOfEntries | array r g b | array _ Array new: numberOfEntries. 1 to: array size do: [ :i | r _ self next. g _ self next. b _ self next. array at: i put: (Color r: r g: g b: b range: 255) ]. ^array! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:49'! readHeader | is89 byte hasColorMap | (self hasMagicNumber: 'GIF87a' asByteArray) ifTrue: [is89 _ false] ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray) ifTrue: [is89 _ true] ifFalse: [^ self error: 'This does not appear to be a GIF file']]. self readWord. "skip Screen Width" self readWord. "skip Screen Height" byte _ self next. hasColorMap _ (byte bitAnd: 16r80) ~= 0. bitsPerPixel _ (byte bitAnd: 7) + 1. byte _ self next. "skip background color." self next ~= 0 ifTrue: [is89 ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']]. hasColorMap ifTrue: [colorPalette _ self readColorTable: (1 bitShift: bitsPerPixel)] ifFalse: ["Transcript cr; show: 'GIF file does not have a color map.'." colorPalette _ nil "Palette monochromeDefault"].! ! !GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'! close "Write terminator" self nextPut: Terminator. ^super close! ! !GIFReadWriter class methodsFor: 'examples' stamp: 'bf 5/29/2003 01:56'! exampleAnim "GIFReadWriter exampleAnim" | writer extent center | writer := GIFReadWriter on: (FileStream newFileNamed: 'anim.gif'). writer loopCount: 20. "Repeat 20 times" writer delay: 10. "Wait 10/100 seconds" extent := 42@42. center := extent / 2. Cursor write showWhile: [ [2 to: center x - 1 by: 2 do: [:r | "Make a fancy anim without using Canvas - inefficient as hell" | image | image := ColorForm extent: extent depth: 8. 0.0 to: 359.0 do: [:theta | image colorAt: (center + (Point r: r degrees: theta)) rounded put: Color red]. writer nextPutImage: image] ] ensure: [writer close]].! ! !GIFReadWriter class methodsFor: 'examples' stamp: 'nk 7/30/2004 21:40'! grabScreenAndSaveOnDisk "GIFReaderWriter grabScreenAndSaveOnDisk" | form fileName | form := Form fromUser. form bits size = 0 ifTrue: [^Beeper beep]. fileName := FileDirectory default nextNameFor: 'Squeak' extension: 'gif'. Utilities informUser: 'Writing ' , fileName during: [GIFReadWriter putForm: form onFileNamed: fileName]! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" self allSubclasses detect: [:cls | cls wantsToHandleGIFs ] ifNone: ["if none of my subclasses wants , then i''ll have to do" ^ #('gif' )]. ^ #( )! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^ false! ! !GSMCodec class methodsFor: 'instance creation' stamp: 'jm 10/21/2001 10:10'! new ^ super new reset ! ! !GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! gzipMagic ^GZipMagic! ! !GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! initialize "GZipConstants initialize" GZipMagic := 16r8B1F. "GZIP magic number" GZipDeflated := 8. "Compression method" GZipAsciiFlag := 16r01. "Contents is ASCII" GZipContinueFlag := 16r02. "Part of a multi-part archive" GZipExtraField := 16r04. "Archive has extra fields" GZipNameFlag := 16r08. "Archive has original file name" GZipCommentFlag := 16r10. "Archive has comment" GZipEncryptFlag := 16r20. "Archive is encrypted" GZipReservedFlags := 16rC0. "Reserved" ! ! !GZipReadStream methodsFor: 'initialize' stamp: 'ar 2/29/2004 03:32'! on: aCollection from: firstIndex to: lastIndex "Check the header of the GZIP stream." | method magic flags length | super on: aCollection from: firstIndex to: lastIndex. crc _ 16rFFFFFFFF. magic _ self nextBits: 16. (magic = GZipMagic) ifFalse:[^self error:'Not a GZipped stream']. method _ self nextBits: 8. (method = GZipDeflated) ifFalse:[^self error:'Bad compression method']. flags _ self nextBits: 8. (flags anyMask: GZipEncryptFlag) ifTrue:[^self error:'Cannot decompress encrypted stream']. (flags anyMask: GZipReservedFlags) ifTrue:[^self error:'Cannot decompress stream with unknown flags']. "Ignore stamp, extra flags, OS type" self nextBits: 16; nextBits: 16. "stamp" self nextBits: 8. "extra flags" self nextBits: 8. "OS type" (flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored" ifTrue:[self nextBits: 16]. (flags anyMask: GZipExtraField) "Extra fields - ignored" ifTrue:[ length _ self nextBits: 16. 1 to: length do:[:i| self nextBits: 8]]. (flags anyMask: GZipNameFlag) "Original file name - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. (flags anyMask: GZipCommentFlag) "Comment - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. ! ! !GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:30'! updateCrc: oldCrc from: start to: stop in: aCollection "Answer an updated CRC for the range of bytes in aCollection" ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection.! ! !GZipReadStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:20'! verifyCrc | stored | stored := 0. 0 to: 24 by: 8 do: [ :i | sourcePos >= sourceLimit ifTrue: [ ^ self crcError: 'No checksum (proceed to ignore)' ]. stored := stored + (self nextByte bitShift: i) ]. stored := stored bitXor: 16rFFFFFFFF. stored = crc ifFalse: [ ^ self crcError: 'Wrong checksum (proceed to ignore)' ]. ^stored! ! !GZipReadStream class methodsFor: 'class initialization' stamp: 'SD 11/15/2001 22:21'! unload FileList unregisterFileReader: self ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 8/18/2004 20:24'! fileIn: fullFileName "FileIn the contents of a gzipped file" | zipped unzipped | zipped _ self on: (FileStream readOnlyFileNamed: fullFileName). unzipped _ MultiByteBinaryOrTextStream with: (zipped contents asString). unzipped reset. unzipped fileIn. ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 21:32'! fileIntoNewChangeSet: fullFileName "FileIn the contents of a gzipped file" | zipped unzipped cs | cs _ Smalltalk at: #ChangeSorter ifAbsent: [ ^self ]. zipped _ self on: (FileStream readOnlyFileNamed: fullFileName). unzipped _ MultiByteBinaryOrTextStream with: zipped contents asString. unzipped reset. cs newChangesFromStream: unzipped named: (FileDirectory localNameFor: fullFileName) ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'yo 7/5/2004 21:10'! fileReaderServicesForFile: fullName suffix: suffix | services | (suffix = 'gz') | (suffix = '*') ifFalse: [^ #()]. services _ OrderedCollection new. (suffix = '*') | (fullName asLowercase endsWith: '.cs.gz') | (fullName asLowercase endsWith: '.mcs.gz') ifTrue: [services add: self serviceFileIn. (Smalltalk includesKey: #ChangeSorter) ifTrue: [services add: self serviceFileIntoNewChangeSet]]. services addAll: self services. ^ services! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'LEG 10/24/2001 23:56'! saveContents: fullFileName "Save the contents of a gzipped file" | zipped buffer unzipped newName | newName _ fullFileName copyUpToLast: FileDirectory extensionDelimiter. unzipped _ FileStream newFileNamed: newName. unzipped binary. zipped _ GZipReadStream on: (FileStream readOnlyFileNamed: fullFileName). buffer _ ByteArray new: 50000. 'Extracting ' , fullFileName displayProgressAt: Sensor cursorPoint from: 0 to: zipped sourceStream size during: [:bar | [zipped atEnd] whileFalse: [bar value: zipped sourceStream position. unzipped nextPutAll: (zipped nextInto: buffer)]. zipped close. unzipped close]. ^ newName! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 11/26/2002 12:11'! serviceDecompressToFile ^ FileModifyingSimpleServiceEntry provider: self label: 'decompress to file' selector: #saveContents: description: 'decompress to file'! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:14'! serviceFileIn "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'fileIn entire file' selector: #fileIn: description: 'file in the entire decompressed contents of the file, which is expected to contain Smalltalk code in fileout ("chunk") format' buttonLabel: 'filein' ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'nk 12/13/2002 11:26'! serviceFileIntoNewChangeSet "Answer a service for filing in an entire file" ^ SimpleServiceEntry provider: self label: 'install into new change set' selector: #fileIntoNewChangeSet: description: 'install the decompressed contents of the file as a body of code in the image: create a new change set and file-in the selected file into it' buttonLabel: 'install'! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:15'! serviceViewDecompress ^ SimpleServiceEntry provider: self label: 'view decompressed' selector: #viewContents: description: 'view decompressed' ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:16'! services ^ Array with: self serviceViewDecompress with: self serviceDecompressToFile ! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'dgd 9/21/2003 17:46'! uncompressedFileName: fullName ^((fullName endsWith: '.gz') and: [self confirm: ('{1} appears to be a compressed file. Do you want to uncompress it?' translated format:{fullName})]) ifFalse: [fullName] ifTrue:[self saveContents: fullName]! ! !GZipReadStream class methodsFor: 'fileIn/Out' stamp: 'sw 3/12/2002 19:34'! viewContents: fullFileName "Open the decompressed contents of the .gz file with the given name. This method is only required for the registering-file-list of Squeak 3.3a and beyond, but does no harm in an earlier system" (FileStream readOnlyFileNamed: fullFileName) ifNotNilDo: [:aStream | aStream viewGZipContents]! ! !GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2001 19:08'! nextWordsPutAll: aCollection "Write the argument a word-like object in big endian format on the receiver. May be used to write other than plain word-like objects (such as ColorArray)." ^self nextPutAllWordArray: aCollection! ! !GZipSurrogateStream methodsFor: 'as yet unclassified' stamp: 'nk 7/29/2004 10:10'! timeStamp "Append the current time to the receiver as a String." self bufferStream nextChunkPut: "double string quotes and !!s" (String streamContents: [:s | SmalltalkImage current timeStamp: s]) printString. self bufferStream cr! ! !GZipWriteStream methodsFor: 'initialize-release' stamp: 'nk 2/19/2004 08:31'! writeFooter "Write some footer information for the crc" super writeFooter. 0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)]. 0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! ! !GZipWriteStream class methodsFor: 'class initialization' stamp: 'nk 11/26/2002 13:09'! initialize FileList registerFileReader: self! ! !GZipWriteStream class methodsFor: 'class initialization' stamp: 'nk 11/26/2002 13:09'! unload FileList unregisterFileReader: self! ! !GZipWriteStream class methodsFor: 'file list services' stamp: 'sw 11/30/2002 00:11'! compressFile: fileName "Create a compressed file from the file of the given name" (FileStream readOnlyFileNamed: fileName) compressFile! ! !GZipWriteStream class methodsFor: 'file list services' stamp: 'st 9/18/2004 23:44'! fileReaderServicesForFile: fullName suffix: suffix "Don't offer to compress already-compressed files sjc 3-May 2003-added jpeg extension" ^({ 'gz' . 'sar' . 'zip' . 'gif' . 'jpg' . 'jpeg'. 'pr'. 'png'} includes: suffix) ifTrue: [ #() ] ifFalse: [ self services ] ! ! !GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:17'! serviceCompressFile ^ FileModifyingSimpleServiceEntry provider: self label: 'compress file' selector: #compressFile: description: 'compress file using gzip compression, making a new file'! ! !GZipWriteStream class methodsFor: 'file list services' stamp: 'nk 11/26/2002 13:10'! services ^ { self serviceCompressFile }! ! !GeeBookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.909 g: 0.819 b: 0.09! ! !GeeBookMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:10'! initialize "initialize the state of the receiver" super initialize. "" newPagePrototype _ GeeBookPageMorph new extent: Display extent // 3 ! ! !GeeBookMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'! includeInNewMorphMenu ^ false! ! !GeeBookPageMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:07'! includeInNewMorphMenu ^ false! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 20:50'! addGeeMailMenuItemsTo: menu self flag: #convertToBook. "<-- no longer used" menu addUpdating: #showPageBreaksString action: #togglePageBreaks; addUpdating: #keepScrollbarString action: #toggleKeepScrollbar; addLine; add: 'Print...' translated action: #printPSToFile; addLine. thePasteUp allTextPlusMorphs size = 1 ifTrue: [ menu add: 'make 1-column book' translated selector: #makeBookStyle: argument: 1. menu add: 'make 2-column book' translated selector: #makeBookStyle: argument: 2. menu add: 'make 3-column book' translated selector: #makeBookStyle: argument: 3. menu add: 'make 4-column book' translated selector: #makeBookStyle: argument: 4. ] ifFalse: [ menu add: 'make a galley of me' translated action: #makeGalleyStyle. ]. ^menu! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 17:42'! allTextPlusMorphs ^thePasteUp allTextPlusMorphs! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:57'! keepScrollBarAlways ^self valueOfProperty: #keepScrollBarAlways ifAbsent: [false]! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:59'! keepScrollbarString ^self keepScrollBarAlways ifTrue: ['scrollbar stays up'] ifFalse: ['scrollbar stays up']! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 12/5/2001 11:15'! makeBookStyle: nColumns | all totalWidth second columnWidth currY prev columnHeight currX currColumn pageBreakRectangles r rm columnGap pageGap starter | pageBreakRectangles _ OrderedCollection new. all _ thePasteUp allTextPlusMorphs. all size = 1 ifFalse: [^self]. Cursor wait show. starter _ prev _ all first. totalWidth _ self width - 16. columnGap _ 32. pageGap _ 16. columnWidth _ totalWidth - (columnGap * (nColumns - 1)) // nColumns. columnHeight _ self height - 12. currY _ 4. currX _ 4. currColumn _ 1. prev position: currX@currY; width: columnWidth. [ second _ prev makeSuccessorMorph. thePasteUp addMorphBack: second. prev setProperty: #autoFitContents toValue: false; height: columnHeight. (currColumn _ currColumn + 1) <= nColumns ifTrue: [ currX _ currX + columnWidth + columnGap. ] ifFalse: [ r _ 4@(prev bottom + 4) corner: (self right - 4 @ (prev bottom + pageGap - 4)). rm _ RectangleMorph new bounds: r; color: (Color gray alpha: 0.3); borderWidth: 0. pageBreakRectangles add: rm beSticky. thePasteUp addMorphBack: rm. currColumn _ 1. currX _ 4. currY _ prev bottom + pageGap. ]. second autoFit: true; position: currX@currY; width: columnWidth. prev recomposeChain. "was commented" prev _ second. prev height > columnHeight ] whileTrue. prev autoFit: true. thePasteUp height: (prev bottom + 20 - self top). self layoutChanged. self setProperty: #pageBreakRectangles toValue: pageBreakRectangles. thePasteUp allTextPlusMorphs do: [ :each | each repositionAnchoredMorphs ]. Cursor normal show. ! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/30/2001 12:12'! makeGalleyStyle | all first theRest | (self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]) do: [ :each | each delete ]. self removeProperty: #pageBreakRectangles. all _ thePasteUp allTextPlusMorphs. first _ all select: [ :x | x predecessor isNil]. first size = 1 ifFalse: [^self]. Cursor wait show. first _ first first. theRest _ all reject: [ :x | x predecessor isNil]. theRest do: [ :each | each delete]. first autoFit: true. first width: self width - 8. first recomposeChain. first repositionAnchoredMorphs. Cursor normal show. ! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:25'! pageRectanglesForPrinting | pageBreaks prevBottom pageRects r | pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [^nil]. prevBottom _ 0. pageRects _ pageBreaks collect: [ :each | r _ 0@prevBottom corner: self width @ each top. prevBottom _ each bottom. r ]. pageRects add: (0@prevBottom corner: self width @ thePasteUp bottom). ^pageRects! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/4/2001 09:21'! scrollSelectionIntoView: event alignTop: alignTop inTextMorph: tm "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere | selRects _ tm paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest _ selRects first merge: selRects last. transform _ scroller transformFrom: self. (event notNil and: [event isMouse and: [event anyButtonPressed]]) ifTrue: "Check for autoscroll" [cpHere _ transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest _ selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect _ transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [^ false]. "Would not fit, even if we tried to scroll" alignTop ifTrue: [ self scrollBy: 0@(bounds top - selRect top). ^ true ]. selRect bottom > bounds bottom ifTrue: [ self scrollBy: 0@(bounds bottom - selRect bottom - 30). ^ true ]. (delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue: [ "Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:06'! scrollToPage: pageNumber | rects oneRect | rects _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. oneRect _ rects at: pageNumber - 1 ifAbsent: [0@0 extent: 0@0]. self scrollToYAbsolute: oneRect bottom. ! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/3/2001 13:01'! scrollToYAbsolute: yValue | transform transformedPoint | transform _ scroller transformFrom: self. transformedPoint _ transform localPointToGlobal: 0@yValue. self scrollBy: 0@(bounds top - transformedPoint y). ! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:10'! showPageBreaksString ^(thePasteUp ifNil: [^'???']) showPageBreaksString! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/21/2001 12:58'! toggleKeepScrollbar self setProperty: #keepScrollBarAlways toValue: self keepScrollBarAlways not! ! !GeeMailMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:12'! togglePageBreaks (thePasteUp ifNil: [^self]) togglePageBreaks! ! !GeeMailMorph methodsFor: 'event handling' stamp: 'RAA 5/3/2001 17:33'! handlesMouseDown: evt ^evt yellowButtonPressed ! ! !GeeMailMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:54'! extraScrollRange ^ bounds height ! ! !GeeMailMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !GeeMailMorph methodsFor: 'initialization' stamp: 'gm 3/10/2003 22:58'! initialize "initialize the state of the receiver" super initialize. "" self initializeThePasteUp. self position: 100@100. self extent: Display extent // 3. self useRoundedCorners. ! ! !GeeMailMorph methodsFor: 'initialization' stamp: 'jam 3/9/2003 16:38'! initializeThePasteUp "initialize the receiver's thePasteUp" thePasteUp _ TextPlusPasteUpMorph new borderWidth: 0; color: color. scroller addMorph: thePasteUp! ! !GeeMailMorph methodsFor: 'layout' stamp: 'RAA 3/5/2001 23:19'! doLayoutIn: layoutBounds "layout has changed. update scroll deltas or whatever else" self adjustPasteUpSize. scroller ifNotNil: [self setScrollDeltas]. super doLayoutIn: layoutBounds. ! ! !GeeMailMorph methodsFor: 'menu' stamp: 'RAA 5/3/2001 17:50'! getMenu: shiftKeyState | menu | self flag: #convertToBook. "<-- no longer used" menu _ MenuMorph new defaultTarget: self. self addGeeMailMenuItemsTo: menu. ^menu! ! !GeeMailMorph methodsFor: 'menus' stamp: 'RAA 5/3/2001 17:50'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addGeeMailMenuItemsTo: aCustomMenu.! ! !GeeMailMorph methodsFor: 'scroll bar events' stamp: 'nk 4/28/2004 10:22'! scrollBarValue: scrollValue | newPt pageBreaks topOfPage | scroller hasSubmorphs ifFalse: [^ self]. newPt _ -3 @ (self vLeftoverScrollRange * scrollValue). pageBreaks _ self valueOfProperty: #pageBreakRectangles ifAbsent: [#()]. pageBreaks isEmpty ifTrue: [ ^scroller offset: newPt. ]. topOfPage _ pageBreaks inject: (0@0 corner: 0@0) into: [ :closest :each | (each bottom - newPt y) abs < (closest bottom - newPt y) abs ifTrue: [ each ] ifFalse: [ closest ]. ]. topOfPage ifNotNil: [ newPt _ newPt x @ topOfPage bottom. scrollBar value: newPt y / self vLeftoverScrollRange. ]. scroller offset: newPt.! ! !GeeMailMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:14'! vHideScrollBar self keepScrollBarAlways ifTrue: [^self]. ^super vHideScrollBar! ! !GeeMailMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 5/7/2001 12:20'! printPSToFile thePasteUp printer geeMail: self; doPages! ! !GeeMailMorph methodsFor: '*customevents-access' stamp: 'nk 10/12/2003 13:22'! visibleMorphs "Answer a collection of morphs that were visible as of the last step" ^Array withAll: (self valueOfProperty: #visibleMorphs ifAbsentPut: [ WeakArray new ]).! ! !GeeMailMorph methodsFor: '*customevents-access' stamp: 'nk 10/12/2003 13:22'! visibleMorphs: morphs "Answer a collection of morphs that were visible as of the last step" self setProperty: #visibleMorphs toValue: (WeakArray withAll: morphs)! ! !GeeMailMorph methodsFor: '*customevents-stepping and presenter' stamp: 'nk 10/12/2003 13:23'! step "For each submorph of thePasteUp that has just been scrolled into view, fire the script named #scrolledIntoView, if any. For each submorph of thePasteUp that has just been scrolled out of view, fire the script named #scrolledOutOfView, if any." | lastVisible nowVisible newlyVisible newlyInvisible | super step. lastVisible _ self visibleMorphs. nowVisible _ (thePasteUp submorphs copyWithoutAll: (self allTextPlusMorphs)) select: [ :m | self bounds intersects: (m boundsIn: self world) ]. newlyInvisible _ lastVisible difference: nowVisible. newlyInvisible do: [ :ea | ea triggerEvent: #scrolledOutOfView ]. newlyVisible _ nowVisible difference: lastVisible. newlyVisible do: [ :ea | ea triggerEvent: #scrolledIntoView ]. self visibleMorphs: nowVisible. ! ! !GeeMailMorph methodsFor: '*customevents' stamp: 'nk 10/12/2003 13:23'! releaseCachedState super releaseCachedState. self removeProperty: #visibleMorphs! ! !GeeMailMorph commentStamp: '' prior: 0! GeeMail is a scrolling playfield with a text morph (typically on the left) and room on the right for other morphs to be placed. The morphs on the right can be linked to text selections on the left so that they remain positioned beside the pertinent text as the text is reflowed. Probably the best thing is and example and Alan will be making some available soon.! !GeeMailMorph class methodsFor: '*customevents-class initialization' stamp: 'nk 7/20/2003 12:34'! initialize "AlansTextPlusMorph initialize" ScriptingSystem addCustomEventFor: self named: #scrolledIntoView help: 'when I am scrolled into view in a GeeMailMorph'. ScriptingSystem addCustomEventFor: self named: #scrolledOutOfView help: 'when I am scrolled out of view in a GeeMailMorph'. ! ! !GeeMailMorph class methodsFor: '*customevents-class initialization' stamp: 'nk 7/20/2003 12:36'! unload ScriptingSystem removeCustomEventNamed: #scrolledIntoView for: self. ScriptingSystem removeCustomEventNamed: #scrolledOutOfView for: self.! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:37'! allPages | pageNumber allPages maxPages | maxPages _ 9999. pageNumber _ 0. allPages _ self pageRectangles collect: [ :rect | pageNumber _ pageNumber + 1. (self as: GeePrinterPage) pageNumber: pageNumber bounds: rect ]. allPages size > maxPages ifTrue: [allPages _ allPages first: maxPages]. allPages do: [ :each | each totalPages: allPages size]. ^allPages ! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'! bounds ^computedBounds ifNil: [computedBounds _ self computeBounds]! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:49'! computeBounds | w ratio | w _ pasteUp width. self printSpecs scaleToFitPage ifTrue: [ ^0@0 extent: w@(w * self hOverW) rounded. ]. ratio _ 8.5 @ 11. self printSpecs landscapeFlag ifTrue: [ ratio _ ratio transposed ]. ^0@0 extent: (ratio * 72) rounded! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 12:20'! geeMail: aGeeMail geeMail _ aGeeMail! ! !GeePrinter methodsFor: 'as yet unclassified' stamp: 'RAA 5/7/2001 13:32'! pageRectangles | pageBounds allPageRects maxExtent | geeMail ifNotNil: [ allPageRects _ geeMail pageRectanglesForPrinting. allPageRects ifNotNil: [ maxExtent _ allPageRects inject: 0@0 into: [ :max :each | max max: each extent ]. computedBounds _ 0@0 extent: maxExtent. ^allPageRects ]. ]. pageBounds _ self bounds. allPageRects _ OrderedCollection new. [pageBounds top <= pasteUp bottom] whileTrue: [ allPageRects add: pageBounds. pageBounds _ pageBounds translateBy: 0 @ pageBounds height. ]. ^allPageRects ! ! !GeePrinter methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 5/7/2001 12:54'! doPrintToPrinter "fileName _ ('gee.',Time millisecondClockValue printString,'.eps') asFileName." self pageRectangles. "ensure bounds computed" DSCPostscriptCanvasToDisk morphAsPostscript: self rotated: self printSpecs landscapeFlag specs: self printSpecs ! ! !GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:36'! getChoice: aSymbol aSymbol == #landscapeFlag ifTrue: [^printSpecs landscapeFlag]. aSymbol == #drawAsBitmapFlag ifTrue: [^printSpecs drawAsBitmapFlag]. aSymbol == #scaleToFitPage ifTrue: [^printSpecs scaleToFitPage]. ! ! !GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:51'! rebuild self removeAllMorphs. self addARow: { (StringMorph contents: 'PostScript Printing Options') lock. }. self addARow: { self simpleToggleButtonFor: self attribute: #landscapeFlag help: 'Print in landscape mode'. (StringMorph contents: ' Landscape') lock. }. self addARow: { self simpleToggleButtonFor: self attribute: #drawAsBitmapFlag help: 'Print as a bitmap'. (StringMorph contents: ' Bitmap') lock. }. self addARow: { self simpleToggleButtonFor: self attribute: #scaleToFitPage help: 'Scale printing to fill page'. (StringMorph contents: ' Scale to fit') lock. }. self addARow: { self printButton. self previewButton. self cancelButton. }.! ! !GeePrinterDialogMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:50'! toggleChoice: aSymbol aSymbol == #landscapeFlag ifTrue: [ printSpecs landscapeFlag: printSpecs landscapeFlag not ]. aSymbol == #drawAsBitmapFlag ifTrue: [ printSpecs drawAsBitmapFlag: printSpecs drawAsBitmapFlag not ]. aSymbol == #scaleToFitPage ifTrue: [ printSpecs scaleToFitPage: printSpecs scaleToFitPage not ]. ! ! !GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self color darker! ! !GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 8! ! !GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color paleYellow! ! !GeePrinterDialogMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 19:52'! initialize "initialize the state of the receiver" super initialize. "" self vResizing: #shrinkWrap; hResizing: #shrinkWrap; layoutInset: 4; useRoundedCorners. printSpecs ifNil: [printSpecs _ PrintSpecifications defaultSpecs]. self rebuild ! ! !GeePrinterDialogMorph class methodsFor: 'new-morph participation' stamp: 'RAA 2/22/2001 09:08'! includeInNewMorphMenu ^ false! ! !GeePrinterPage methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 2/22/2001 09:05'! fullDrawPostscriptOn: aCanvas | s | s _ TextMorph new beAllFont: (TextStyle default fontOfSize: 30); contentsAsIs: ' Drawing page ',pageNumber printString,' of ',totalPages printString,' '. s layoutChanged; fullBounds. s _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; addMorph: s; color: Color yellow. s position: Display center - (s width // 2 @ 0). World addMorphFront: s. World displayWorld. printSpecs drawAsBitmapFlag ifTrue: [ aCanvas paintImage: self pageAsForm at: 0@0 ] ifFalse: [ aCanvas translateTo: bounds origin negated clippingTo: (0@0 extent: bounds extent) during: [ :c | pasteUp fullDrawForPrintingOn: c ]. ]. s delete. ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:23'! addARow: anArray ^(super addARow: anArray) cellPositioning: #topLeft! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/24/2003 18:06'! buildFakeSlider: nameStringOrSymbol selector: aSymbol help: helpString | col | col := self inAColumn: { (nameStringOrSymbol isKindOf: Symbol) ifTrue: [(UpdatingStringMorph new) useStringFormat; getSelector: nameStringOrSymbol; target: self; growable: true; minimumWidth: 24; lock] ifFalse: [self lockedString: nameStringOrSymbol]}. col borderWidth: 2; borderColor: color darker; color: color muchLighter; hResizing: #shrinkWrap; setBalloonText: helpString; on: #mouseMove send: #mouseAdjust:in: to: self; on: #mouseDown send: #mouseAdjust:in: to: self; on: #mouseUp send: #clearSliderFeedback to: self; setProperty: #changeSelector toValue: aSymbol. ^col! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:35'! buttonNamed: aString action: aSymbol color: aColor help: helpString | f col | f _ SimpleButtonMorph new target: self; label: aString; color: aColor; actionSelector: aSymbol; setBalloonText: helpString. col _ (self inAColumn: {f}) hResizing: #shrinkWrap. ^col! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:41'! clearSliderFeedback | feedBack | feedBack _ self valueOfProperty: #sliderFeedback ifAbsent: [^self]. feedBack delete! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:15'! colorPickerFor: target getter: getterSymbol setter: setterSymbol ^ColorPickerMorph new initializeForPropertiesPanel; target: target; selector: setterSymbol; originalColor: (target perform: getterSymbol)! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:36'! directToggleButtonFor: target getter: getterSymbol setter: setterSymbol help: helpText ^(EtoyUpdatingThreePhaseButtonMorph checkBox) target: target; actionSelector: setterSymbol; arguments: #(); getSelector: getterSymbol; setBalloonText: helpText; step ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:36'! doAccept self delete! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:50'! doButtonProperties myTarget openAButtonPropertySheet. self delete. ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 19:40'! doCancel thingsToRevert keysAndValuesDo: [ :k :v | myTarget perform: k with: v ]. self delete! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:24'! doEnables! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:50'! doMainProperties myTarget openAPropertySheet. self delete. ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/15/2001 12:57'! doTextProperties myTarget openATextPropertySheet. self delete. ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:23'! enable: aMorph when: aBoolean aBoolean = (aMorph hasProperty: #disabledMaskColor) ifFalse: [^self]. aBoolean ifTrue: [ aMorph removeProperty: #disabledMaskColor; lock: false; changed. ^self ]. aMorph setProperty: #disabledMaskColor toValue: (Color black alpha: 0.5); lock: true; changed ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'! inAColumn: aCollectionOfMorphs | col | col _ AlignmentMorphBob1 newColumn color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #topCenter. aCollectionOfMorphs do: [ :each | col addMorphBack: each]. ^col! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'! inAColumn: anArray named: aString ^(self inAColumn: anArray) setNamePropertyTo: aString! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 12:27'! inARow: aCollectionOfMorphs | row | row _ AlignmentMorphBob1 newRow color: Color transparent; vResizing: #shrinkWrap; layoutInset: 1; wrapCentering: #center; cellPositioning: #leftCenter. aCollectionOfMorphs do: [ :each | row addMorphBack: each]. ^row ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 16:22'! inARow: anArray named: aString ^(self inARow: anArray) setNamePropertyTo: aString! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 14:37'! lockedString: s ^(StringMorph contents: s) lock. ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:22'! mouseAdjust: evt in: aMorph | fractionalPosition feedBack testExtent | feedBack _ self showSliderFeedback: nil. feedBack world ifNil: [ feedBack bottomLeft: evt cursorPoint - (0@8) ]. testExtent _ 100@100. "the real extent may change" fractionalPosition _ (evt cursorPoint - aMorph topLeft) / testExtent. self perform: (aMorph valueOfProperty: #changeSelector) with: fractionalPosition ! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 13:09'! openNearTarget | w wb tb leftOverlap rightOverlap topOverlap bottomOverlap best | w _ myTarget world ifNil: [World]. wb _ w bounds. self fullBounds. tb _ myTarget boundsInWorld. leftOverlap _ self width - (tb left - wb left). rightOverlap _ self width - (wb right - tb right). topOverlap _ self height - (tb top - wb top). bottomOverlap _ self height - (wb bottom - tb bottom). best _ nil. { {leftOverlap. #topRight:. #topLeft}. {rightOverlap. #topLeft:. #topRight}. {topOverlap. #bottomLeft:. #topLeft}. {bottomOverlap. #topLeft:. #bottomLeft}. } do: [ :tuple | (best isNil or: [tuple first < best first]) ifTrue: [best _ tuple]. ]. self perform: best second with: (tb perform: best third). self bottom: (self bottom min: wb bottom) rounded. self right: (self right min: wb right) rounded. self top: (self top max: wb top) rounded. self left: (self left max: wb left) rounded. self openInWorld: w.! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/9/2001 10:12'! showSliderFeedback: aString | feedBack | feedBack _ self valueOfProperty: #sliderFeedback ifAbsent: [ feedBack _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: (Color yellow" alpha: 0.6"); addMorph: ( TextMorph new contents: '?'; beAllFont: ((TextStyle default fontOfSize: 24) emphasized: 1) ). self setProperty: #sliderFeedback toValue: feedBack. feedBack ]. aString ifNotNil: [ feedBack firstSubmorph contents: aString asString. feedBack world ifNil: [feedBack openInWorld]. ]. ^feedBack! ! !GenericPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:01'! targetMorph: x myTarget _ x! ! !GenericPropertiesMorph methodsFor: 'dropping/grabbing' stamp: 'tk 7/11/2001 14:00'! wantsToBeDroppedInto: aMorph "Return true if it's okay to drop the receiver into aMorph" ^aMorph isWorldMorph or:[Preferences systemWindowEmbedOK]! ! !GenericPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:15'! defaultBorderWidth "answer the default border width for the receiver" ^ 4! ! !GenericPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:16'! initialize "initialize the state of the receiver" super initialize. "" self layoutInset: 4. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. thingsToRevert _ Dictionary new. self useRoundedCorners! ! !GenericPropertiesMorph methodsFor: 'stepping and presenter' stamp: 'RAA 3/8/2001 16:24'! step super step. self doEnables! ! !GenericPropertiesMorph methodsFor: 'testing' stamp: 'RAA 3/8/2001 16:24'! stepTime ^500! ! !GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'! scheme ^ self schemeName.! ! !GetTriggeringObjectNotification commentStamp: '' prior: 0! This is used to report on the sender of #triggerScript:! !GrabPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:51'! initialize "Initialize the receiver. Emblazon the GrabPatch icon on its face" super initialize. self image: (ScriptingSystem formAtKey: 'GrabPatch')! ! !GrabPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:51'! initializeToStandAlone "Initialize the receiver. Emblazon the GrabPatch icon on its face" super initializeToStandAlone. self image: (ScriptingSystem formAtKey: 'GrabPatch')! ! !GrabPatchMorph methodsFor: 'misc' stamp: 'sw 7/5/2004 01:49'! isCandidateForAutomaticViewing "Answer whether the receiver is a candidate for automatic viewing. Only relevant if a now-seldom-used feature, automaticViewing, is in play" ^ self isPartsDonor not! ! !GrabPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 15:52'! justDroppedInto: aPasteUpMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph" aPasteUpMorph isPartsBin ifFalse: [self delete. ActiveWorld displayWorldSafely; runStepMethods. "But the HW cursor stays up still ???" ^ aPasteUpMorph grabDrawingFromScreen: anEvent]. ^ super justDroppedInto: aPasteUpMorph event: anEvent! ! !GrabPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 14:40'! wantsToBeDroppedInto: aMorph "Only into PasteUps that are not part bins" ^ aMorph isPlayfieldLike! ! !GrabPatchMorph commentStamp: 'sw 8/1/2004 13:27' prior: 0! When an instance of GrabPatchMorph is dropped by the user, it signals a desire to do a screen-grab of a rectangular area.! !GrabPatchMorph class methodsFor: 'instance creation' stamp: 'sw 7/5/2004 01:53'! authoringPrototype "Answer a prototype for use in a parts bin" ^ self new image: (ScriptingSystem formAtKey: 'GrabPatch'); markAsPartsDonor; setBalloonText: 'Use this to grab a rectangular patch from the screen'; yourself! ! !GrabPatchMorph class methodsFor: 'parts bin' stamp: 'sw 7/5/2004 01:51'! descriptionForPartsBin "Answer a description of the receiver's instances for a parts bin" ^ self partName: 'Grab Patch' categories: #('Graphics') documentation: 'Use this to grab a rectangular patch from the screen'! ! !GradientFillMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:15'! drawOn: aCanvas "Note that this could run about 4 times faster if we got hold of the canvas's port and just sent it copyBits with new coords and color" | style | super drawOn: aCanvas. (color isColor) ifFalse: [^self]. "An InfiniteForm, for example" color = Color transparent ifTrue: [^self]. "Skip the gradient attempts, which will drop into debugger" color = fillColor2 ifTrue: [^self]. "same color; no gradient" "Check if we can use the cached gradient fill" ((self valueOfProperty: #cachedGradientColor1) = color and: [(self valueOfProperty: #cachedGradientColor2) = fillColor2]) ifTrue: [style := self valueOfProperty: #cachedGradientFill]. style ifNil: [style := GradientFillStyle ramp: { 0.0 -> color. 1.0 -> fillColor2}. self setProperty: #cachedGradientColor1 toValue: color. self setProperty: #cachedGradientColor2 toValue: fillColor2. self setProperty: #cachedGradientFill toValue: style]. style origin: self position. style direction: (gradientDirection == #vertical ifTrue: [0 @ self height] ifFalse: [self width @ 0]). aCanvas fillRectangle: self innerBounds fillStyle: style! ! !GradientFillMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:45'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'gradient color' translated action: #setGradientColor:. gradientDirection == #vertical ifTrue: [aCustomMenu add: 'horizontal pan' translated action: #beHorizontal] ifFalse: [aCustomMenu add: 'vertical pan' translated action: #beVertical]. ! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 8/31/2004 11:06'! radial ^radial ifNil:[false]! ! !GradientFillStyle methodsFor: 'converting' stamp: 'ar 8/25/2001 21:02'! asColor "Guess..." ^colorRamp first value mixed: 0.5 with: colorRamp last value! ! !GradientFillStyle methodsFor: 'converting' stamp: 'ar 6/4/2001 00:42'! mixed: fraction with: aColor ^self copy colorRamp: (colorRamp collect:[:assoc| assoc key -> (assoc value mixed: fraction with: aColor)])! ! !GradientFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:37'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" self isRadialFill ifTrue:[ aMenu add: 'linear gradient' translated target: self selector: #beLinearGradientIn: argument: aMorph. ] ifFalse:[ aMenu add: 'radial gradient' translated target: self selector: #beRadialGradientIn: argument: aMorph. ]. aMenu addLine. aMenu add: 'change first color' translated target: self selector: #changeFirstColorIn:event: argument: aMorph. aMenu add: 'change second color' translated target: self selector: #changeSecondColorIn:event: argument: aMorph. aMenu addLine. super addFillStyleMenuItems: aMenu hand: aHand from: aMorph.! ! !GradientFillStyle methodsFor: 'Morphic menu' stamp: 'nk 7/18/2003 16:35'! firstColor: aColor forMorph: aMorph hand: aHand colorRamp first value: aColor. isTranslucent _ nil. pixelRamp _ nil. aMorph changed.! ! !GradientFillStyle methodsFor: 'Morphic menu' stamp: 'nk 7/18/2003 16:35'! lastColor: aColor forMorph: aMorph hand: aHand colorRamp last value: aColor. isTranslucent _ nil. pixelRamp _ nil. aMorph changed.! ! !GradientFillStyle commentStamp: '' prior: 0! A gradient fill style is a fill which interpolates smoothly between any number of colors. Instance variables: colorRamp Contains the colors and their relative positions along the fill, which is a number between zero and one. pixelRamp A cached version of the colorRamp to avoid needless recomputations. radial If true, this fill describes a radial gradient. If false, it is a linear gradient. isTranslucent A (cached) flag determining if there are any translucent colors involved.! !GradientFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 23:09'! colors: colorArray "Create a gradient fill style from an array of equally spaced colors" ^self ramp: (colorArray withIndexCollect: [:color :index| (index-1 asFloat / (colorArray size - 1 max: 1)) -> color]).! ! !GrafPort methodsFor: 'accessing' stamp: 'yo 1/23/2003 17:33'! displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ((para isMemberOf: MultiNewParagraph) or: [para text string class == String]) ifTrue: [ ^ (MultiDisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self clone ]. ^ (DisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self clone ! ! !GrafPort methodsFor: 'accessing' stamp: 'yo 1/23/2003 17:48'! displayScannerForMulti: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ((para isMemberOf: MultiNewParagraph) or: [para text string class == String]) ifTrue: [ ^ (MultiDisplayScanner new text: para presentationText textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self clone ]. ^ (DisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self clone ! ! !GrafPort methodsFor: 'copying' stamp: 'ar 12/30/2001 20:32'! clippedBy: aRectangle ^ self copy clipBy: aRectangle! ! !GrafPort methodsFor: 'copying' stamp: 'dgd 2/21/2003 22:38'! copyBits "Override copybits to do translucency if desired" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: [alpha isNil ifTrue: [self copyBitsTranslucent: 255] ifFalse: [self copyBitsTranslucent: alpha]] ifFalse: [super copyBits]! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'! frameRect: rect borderWidth: borderWidth sourceX _ 0. sourceY _ 0. (rect areasOutside: (rect insetBy: borderWidth)) do: [:edgeStrip | self destRect: edgeStrip; copyBits]. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 8/8/2001 14:26'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: sourceAlpha "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." sourceForm _ aForm. combinationRule _ rule. self sourceRect: sourceRect. self destOrigin: aPoint. self copyBitsTranslucent: (alpha _ (sourceAlpha * 255) truncated min: 255 max: 0).! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! installStrikeFont: aStrikeFont ^ self installStrikeFont: aStrikeFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]). ! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:11'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor super installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor. alpha _ foregroundColor privateAlpha. "dynamically switch between blend modes to support translucent text" "To handle the transition from TTCFont to StrikeFont, rule 34 must be taken into account." alpha = 255 ifTrue:[ combinationRule = 30 ifTrue: [combinationRule _ Form over]. combinationRule = 31 ifTrue: [combinationRule _ Form paint]. combinationRule = 34 ifTrue: [combinationRule _ Form paint]. ] ifFalse:[ combinationRule = Form over ifTrue: [combinationRule _ 30]. combinationRule = Form paint ifTrue: [combinationRule _ 31]. combinationRule = 34 ifTrue: [combinationRule _ 31]. ]. lastFont _ aStrikeFont. lastFontForegroundColor _ foregroundColor. lastFontBackgroundColor _ backgroundColor. ! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/12/2005 16:39'! installTTCFont: aTTCFont ^ self installTTCFont: aTTCFont foregroundColor: (lastFontForegroundColor ifNil: [Color black]) backgroundColor: (lastFontBackgroundColor ifNil: [Color transparent]). ! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:12'! installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor super installTTCFont: aTTCFont foregroundColor: foregroundColor backgroundColor: backgroundColor. lastFont _ aTTCFont. lastFontForegroundColor _ foregroundColor. lastFontBackgroundColor _ backgroundColor. ! ! !GrafPort methodsFor: 'private' stamp: 'yo 1/8/2005 09:13'! lastFont ^ lastFont. ! ! !GraphMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:40'! interpolatedValueAtCursor | sz prev frac next | data isEmpty ifTrue: [^0]. sz := data size. cursor < 0 ifTrue: [^data first]. "just to be safe, though cursor shouldn't be negative" prev := cursor truncated. frac := cursor - prev. prev < 1 ifTrue: [prev := sz]. prev > sz ifTrue: [prev := 1]. "assert: 1 <= prev <= sz" frac = 0 ifTrue: [^data at: prev]. "no interpolation needed" "interpolate" next := prev = sz ifTrue: [1] ifFalse: [prev + 1]. ^(1.0 - frac) * (data at: prev) + (frac * (data at: next))! ! !GraphMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:40'! lastValue data isEmpty ifTrue: [^0]. ^data last! ! !GraphMorph methodsFor: 'commands' stamp: 'ads 7/31/2003 11:11'! loadSineWave self loadSoundData: SoundBuffer sineTable. ! ! !GraphMorph methodsFor: 'commands' stamp: 'gk 2/23/2004 21:08'! playOnce | scale absV scaledData | data isEmpty ifTrue: [^ self]. "nothing to play" scale _ 1. data do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]]. scale _ 32767.0 / scale. scaledData _ SoundBuffer newMonoSampleCount: data size. 1 to: data size do: [:i | scaledData at: i put: (scale * (data at: i)) truncated]. SoundService default playSampledSound: scaledData rate: 11025. ! ! !GraphMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:39'! drawOn: aCanvas | c | cachedForm isNil ifTrue: [c := Display defaultCanvasClass extent: bounds extent. c translateBy: bounds origin negated during: [:tempCanvas | self drawDataOn: tempCanvas]. cachedForm := c form]. aCanvas cache: bounds using: cachedForm during: [:cachingCanvas | self drawDataOn: cachingCanvas]. self drawCursorOn: aCanvas! ! !GraphMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 0.8 b: 0.6! ! !GraphMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28'! initialize "initialize the state of the receiver" super initialize. "" self extent: 365 @ 80. dataColor _ Color darkGray. cursor _ 1.0. "may be fractional" cursorColor _ Color red. cursorColorAtZeroCrossings _ Color red. startIndex _ 1. hasChanged _ false. self data: ((0 to: 360 - 1) collect: [:x | (100.0 * x degreesToRadians sin) asInteger])! ! !GraphMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 14:40'! step "Make a deferred damage rectangle if I've changed. This allows applications to call methods that invalidate my display at high-bandwidth without paying the cost of doing the damage reporting on ever call; they can merely set hasChanged to true." super step. hasChanged isNil ifTrue: [hasChanged := false]. hasChanged ifTrue: [self changed. hasChanged := false]! ! !GraphMorph methodsFor: '*sound' stamp: 'dgd 8/30/2003 21:45'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'open wave editor' translated action: #openWaveEditor. aCustomMenu add: 'read file' translated action: #readDataFromFile. ! ! !GraphMorph methodsFor: '*sound' stamp: 'yo 2/16/2005 10:43'! readDataFromFile | fileName | fileName _ FillInTheBlank request: 'File name?' translated initialAnswer: ''. fileName isEmpty ifTrue: [^ self]. (StandardFileStream isAFileNamed: fileName) ifFalse: [ ^ self inform: 'Sorry, I cannot find that file' translated]. self data: (SampledSound fromAIFFfileNamed: fileName) samples. ! ! !GraphMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:50'! descriptionForPartsBin ^ self partName: 'Graph' categories: #('Useful') documentation: 'A graph of numbers, normalized so the full range of values just fits my height. I support a movable cursor that can be dragged with the mouse.'! ! !GraphMorph class methodsFor: 'scripting' stamp: 'sw 9/26/2001 04:19'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #( (basic ( (slot cursor 'The current cursor location, wrapped back to the beginning if appropriate' Number readWrite Player getCursor Player setCursorWrapped:) (slot sampleAtCursor 'The sample value at the current cursor location' Number readWrite Player getSampleAtCursor Player setSampleAtCursor:))) (sampling ( (slot cursor 'The current cursor location, wrapped back to the beginning if appropriate' Number readWrite Player getCursor Player setCursorWrapped:) (slot sampleAtCursor 'The sample value at the current cursor location' Number readWrite Player getSampleAtCursor Player setSampleAtCursor:) (slot lastValue 'The last value obtained' Number readWrite Player getLastValue Player setLastValue:) (command clear 'Clear the graph of current contents') (command loadSineWave 'Load a sine wave as the current graph') (command loadSound: 'Load the specified sound into the current graph' Sound) (command reverse 'Reverse the graph') (command play 'Play the current graph as a sound'))))! ! !GraphicTile methodsFor: 'accessing' stamp: 'sw 9/26/2001 04:05'! resultType "Answer the result type of the argument represented by the receiver" ^ #Graphic! ! !GraphicTile methodsFor: 'code generation' stamp: 'sw 4/2/2001 23:09'! storeCodeOn: aStream indent: tabCount "Write code that will reconstitute the receiver" aStream nextPutAll: literal uniqueNameForReference! ! !GraphicTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'! initialize "initialize the state of the receiver" super initialize. "" type _ #literal. self useForm: (ScriptingSystem formAtKey: #Menu)! ! !GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:52'! setLiteral: anObject "Set the receiver's literal to be anObject. No readout morph here." type _ #literal. self setLiteralInitially: anObject. ! ! !GraphicTile methodsFor: 'initialization' stamp: 'sw 4/3/2001 15:40'! useForm: aForm "Set the receiver to represent the given form" | thumbnail | self removeAllMorphs. literal _ aForm. thumbnail _ ThumbnailMorph new objectToView: self viewSelector: #literal. self addMorphBack: thumbnail. thumbnail extent: 16 @ 16.! ! !GraphicTile commentStamp: '' prior: 0! A tile representing a graphic image.! !GraphicType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ GraphicTile new typeColor: self typeColor! ! !GraphicType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:06'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" ^ ThumbnailMorph new objectToView: aTarget viewSelector: getter; extent: 21@21; yourself! ! !GraphicType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ ScriptingSystem formAtKey: #PaintTab! ! !GraphicType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Graphic.! ! !GraphicType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.806 1.0 0.806) ! ! !GraphicalDictionaryMenu methodsFor: 'initialization' stamp: 'nk 1/11/2004 16:22'! initializeFor: aTarget fromDictionary: aDictionary "Initialize me for a target and a dictionary." | anIndex aButton | self baseDictionary: aDictionary. target := aTarget. coexistWithOriginal := true. self extent: 210 @ 210. self clipSubmorphs: true. self layoutPolicy: ProportionalLayout new. aButton := (IconicButton new) borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: 'TinyMenu'); color: Color transparent; actWhen: #buttonDown; actionSelector: #showMenu; target: self; setBalloonText: 'menu'. self addMorph: aButton fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0) offsets: (-50 @ 6 extent: aButton extent)). aButton := (SimpleButtonMorph new) target: self; borderColor: Color black; label: 'Prev'; actionSelector: #downArrowHit; actWhen: #whilePressed; setBalloonText: 'show previous picture'; yourself. self addMorph: aButton fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0) offsets: (-24 @ 4 extent: aButton extent)). aButton := (SimpleButtonMorph new) target: self; borderColor: Color black; label: 'Next'; actionSelector: #upArrowHit; actWhen: #whilePressed; setBalloonText: 'show next pictutre'. self addMorph: aButton fullFrame: (LayoutFrame fractions: (0.5 @ 0 extent: 0 @ 0) offsets: (24 @ 4 extent: aButton extent)). self addMorph: ((UpdatingStringMorph new) contents: ' '; target: self; putSelector: #renameGraphicTo:; getSelector: #truncatedNameOfGraphic; useStringFormat; setBalloonText: 'The name of the current graphic'; yourself) fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 1 @ 0) offsets: (10 @ 40 corner: -10 @ 60)). self addMorph: ((Morph new) extent: 100 @ 4; color: Color black) fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 1 @ 0) offsets: (0 @ 60 corner: 0 @ 64)). formDisplayMorph := (Thumbnail new) extent: 100 @ 100; useInterpolation: true; maxWidth: 3000 minHeight: 100; yourself. self addMorph: formDisplayMorph fullFrame: (LayoutFrame fractions: (0 @ 0 extent: 0@0) offsets: (8 @ 72 corner: 108 @ 172)). self minimumExtent: 116@180. target ifNotNil: [(anIndex := formChoices indexOf: target form ifAbsent: []) ifNotNil: [currentIndex := anIndex]]. self updateThumbnail! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 11/10/2003 13:14'! browseIconReferences "Browse all calls on the symbol by which the currently-seen graphic is keyed" self systemNavigation browseAllCallsOn: self nameOfGraphic! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 11/10/2003 13:14'! browseStringIconReferences "Browse string references to the selected entry's key" self systemNavigation browseMethodsWithString: self nameOfGraphic asString matchCase: true! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 10/25/2002 16:58'! copyName "Copy the name of the current selection to the clipboard" Clipboard clipboardText: self nameOfGraphic asText! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 10/12/2004 05:04'! findAgain "Look for the next occurrence of the search string" | toFind searchIndex | lastSearchString ifNil: [lastSearchString _ 'controls']. searchIndex _ currentIndex + 1. searchIndex > entryNames size ifTrue: [currentIndex _ 0. self inform: 'not found' translated. ^ self]. toFind _ '*', lastSearchString, '*'. [toFind match: (entryNames at: searchIndex) asString] whileFalse: [searchIndex _ (searchIndex \\ entryNames size) + 1. searchIndex == currentIndex ifTrue: [^ (toFind match: (entryNames at: searchIndex) asString) ifFalse: [self inform: 'not found' translated] ifTrue: [self flash]]]. currentIndex _ searchIndex. self updateThumbnail! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:57'! findEntry "Prompt the user for a search string and find the next match for it" | toFind searchIndex | lastSearchString ifNil: [lastSearchString _ 'controls']. toFind _ FillInTheBlank request: 'Type name or fragment: ' initialAnswer: lastSearchString. toFind isEmptyOrNil ifTrue: [^ self]. lastSearchString _ toFind asLowercase. searchIndex _ currentIndex + 1. toFind _ '*', lastSearchString, '*'. [toFind match: (entryNames at: searchIndex) asString] whileFalse: [searchIndex _ (searchIndex \\ entryNames size) + 1. searchIndex == currentIndex ifTrue: [^ self inform: 'not found']]. currentIndex _ searchIndex. self updateThumbnail! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nk 1/6/2004 12:36'! handMeOne self currentHand attachMorph: (World drawingClass new form: (formChoices at: currentIndex))! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nb 6/17/2003 12:25'! renameEntry | reply curr | reply _ FillInTheBlank request: 'New key? ' initialAnswer: (curr _ entryNames at: currentIndex) centerAt: self center. (reply isEmptyOrNil or: [reply = curr]) ifTrue: [^ Beeper beep]. (baseDictionary includesKey: reply) ifTrue: [^ self inform: 'sorry that conflicts with the name of another entry in this dictionary']. baseDictionary at: reply put: (baseDictionary at: curr). baseDictionary removeKey: curr. self baseDictionary: baseDictionary. self updateThumbnail! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nb 6/17/2003 12:25'! renameGraphicTo: newName | curr | curr _ entryNames at: currentIndex. (newName isEmptyOrNil or: [newName = curr]) ifTrue: [^ Beeper beep]. (baseDictionary includesKey: newName) ifTrue: [^ self inform: 'sorry that conflicts with the name of another entry in this dictionary']. baseDictionary at: newName put: (baseDictionary at: curr). baseDictionary removeKey: curr. self baseDictionary: baseDictionary. currentIndex _ entryNames indexOf: newName. self updateThumbnail! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'nk 1/6/2004 12:37'! repaintEntry "Let the user enter into painting mode to repaint the item and save it back." | aWorld bnds sketchEditor aPaintBox formToEdit | (aWorld _ self world) assureNotPaintingElse: [^ self]. aWorld prepareToPaint. aWorld displayWorld. formToEdit _ formChoices at: currentIndex. bnds _ (submorphs second boundsInWorld origin extent: formToEdit extent) intersect: aWorld bounds. bnds _ (aWorld paintingBoundsAround: bnds center) merge: bnds. sketchEditor _ SketchEditorMorph new. aWorld addMorphFront: sketchEditor. sketchEditor initializeFor: ((World drawingClass withForm: formToEdit) position: submorphs second positionInWorld) inBounds: bnds pasteUpMorph: aWorld paintBoxPosition: bnds topRight. sketchEditor afterNewPicDo: [:aForm :aRect | formChoices at: currentIndex put: aForm. baseDictionary at: (entryNames at: currentIndex) put: aForm. self updateThumbnail. (aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]] ifNoBits: [(aPaintBox _ aWorld paintBoxOrNil) ifNotNil: [aPaintBox delete]]. ! ! !GraphicalDictionaryMenu methodsFor: 'menu commands' stamp: 'sw 2/24/2003 15:59'! showMenu "Show the receiver's menu" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Graphics Library'. aMenu addStayUpItem. aMenu addList: #( ('remove' removeEntry 'Remove this entry from the dictionary') ('rename' renameEntry 'Rename this entry') ('repaint' repaintEntry 'Edit the actual graphic for this entry' ) - ('hand me one' handMeOne 'Hand me a morph with this picture as its form') ('browse symbol references' browseIconReferences 'Browse methods that refer to this icon''s name') ('browse string references' browseStringIconReferences' 'Browse methods that refer to string constants that contian this icon''s name) ('copy name' copyName 'Copy the name of this graphic to the clipboard') - ('find...' findEntry 'Find an entry by name') ('find again' findAgain 'Find the next match for the keyword previously searched for')). aMenu popUpInWorld ! ! !GraphicalDictionaryMenu methodsFor: 'private' stamp: 'nk 1/11/2004 15:14'! updateThumbnail super updateThumbnail. (self findA: UpdatingStringMorph) doneWithEdits; contents: (entryNames at: currentIndex) ! ! !GraphicalDictionaryMenu class methodsFor: 'example' stamp: 'sd 5/11/2003 20:53'! example "GraphicalDictionaryMenu example" | aDict | aDict _ Dictionary new. #('ColorTilesOff' 'ColorTilesOn' 'Controls') do: [:aString | aDict at: aString put: (ScriptingSystem formAtKey: aString)]. self openOn: aDict withLabel: 'Testing One Two Three'! ! !GraphicalDictionaryMenu class methodsFor: 'example' stamp: 'sd 5/11/2003 20:56'! example2 "GraphicalDictionaryMenu example2" | aDict | aDict _ Dictionary new. self openOn: aDict withLabel: 'Testing Zero'! ! !GraphicalDictionaryMenu class methodsFor: 'instance creation' stamp: 'nk 1/11/2004 15:50'! openOn: aFormDictionary withLabel: aLabel "open a graphical dictionary in a window having the label aLabel. aFormDictionary should be a dictionary containing as value a form." | inst aWindow | aFormDictionary size isZero ifTrue: [^ self inform: 'Empty!!']. inst := self new initializeFor: nil fromDictionary: aFormDictionary. aWindow _ (SystemWindow labelled: aLabel) model: inst. aWindow addMorph: inst frame: (0@0 extent: 1@1). aWindow extent: inst fullBounds extent + (3 @ aWindow labelHeight + 3); minimumExtent: inst minimumExtent + (3 @ aWindow labelHeight + 3). HandMorph attach: aWindow. ^ inst! ! !GraphicalMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color blue darker! ! !GraphicalMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !GraphicalMenu methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !GraphicalMenu methodsFor: 'initialization' stamp: 'nk 1/11/2004 15:09'! initializeFor: aTarget withForms: formList coexist: aBoolean "World primaryHand attachMorph: (GraphicalMenu new initializeFor: nil withForms: Form allInstances coexist: true)" | buttons bb anIndex buttonCage | target := aTarget. coexistWithOriginal := aBoolean. formChoices := formList. currentIndex := 1. self borderWidth: 1; cellPositioning: #center; color: Color white; hResizing: #shrinkWrap; vResizing: #shrinkWrap. buttons := AlignmentMorph newRow. buttons borderWidth: 0; layoutInset: 0. buttons hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5 @ 5. buttons wrapCentering: #topLeft. buttonCage := AlignmentMorph newColumn. buttonCage hResizing: #shrinkWrap; vResizing: #spaceFill. buttonCage addTransparentSpacerOfSize: 0 @ 10. bb := SimpleButtonMorph new target: self; borderColor: Color black. buttons addMorphBack: (bb label: 'Prev'; actionSelector: #downArrowHit; actWhen: #whilePressed). buttons addTransparentSpacerOfSize: 9 @ 0. bb := SimpleButtonMorph new target: self; borderColor: Color black. buttons addMorphBack: (bb label: 'Next'; actionSelector: #upArrowHit; actWhen: #whilePressed). buttons addTransparentSpacerOfSize: 5 @ 0. buttons submorphs last color: Color white. buttonCage addMorphBack: buttons. buttonCage addTransparentSpacerOfSize: 0 @ 12. buttons := AlignmentMorph newRow. bb := SimpleButtonMorph new target: self; borderColor: Color black. buttons addMorphBack: (bb label: 'OK'; actionSelector: #okay). buttons addTransparentSpacerOfSize: 5 @ 0. bb := SimpleButtonMorph new target: self; borderColor: Color black. buttons addMorphBack: (bb label: 'Cancel'; actionSelector: #cancel). buttonCage addMorphBack: buttons. buttonCage addTransparentSpacerOfSize: 0 @ 10. self addMorphFront: buttonCage. formDisplayMorph := Thumbnail new extent: 100 @ 100; maxWidth: 100 minHeight: 30; yourself. self addMorphBack: (Morph new color: Color white; layoutPolicy: TableLayout new; layoutInset: 4 @ 4; hResizing: #spaceFill; vResizing: #spaceFill; listCentering: #center; addMorphBack: formDisplayMorph; yourself). target ifNotNil: [(anIndex := formList indexOf: target form ifAbsent: []) ifNotNil: [currentIndex := anIndex]]. self updateThumbnail! ! !GraphicalMenu methodsFor: 'event handling' stamp: 'nk 1/11/2004 14:44'! updateThumbnail | f | f _ formChoices at: currentIndex. formDisplayMorph makeThumbnailFromForm: f. ! ! !GreekEnvironment commentStamp: '' prior: 0! This class provides the support for Greek. It is here, but most of the methods are not implemented yet. ! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 00:38'! leadingChar ^ 13. ! ! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:23'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('el' )! ! !HTTPClient class methodsFor: 'class initialization' stamp: 'mir 4/2/2002 15:37'! browserSupportsAPI ^BrowserSupportsAPI == true! ! !HTTPClient class methodsFor: 'class initialization' stamp: 'mir 4/2/2002 15:36'! browserSupportsAPI: aBoolean BrowserSupportsAPI _ aBoolean! ! !HTTPClient class methodsFor: 'class initialization' stamp: 'mir 2/2/2001 17:27'! determineIfRunningInBrowser "HTTPClient determineIfRunningInBrowser" RunningInBrowser _ StandardFileStream isRunningAsBrowserPlugin ! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 8/22/2001 12:29'! composeMailTo: address subject: subject body: body "HTTPClient composeMailTo: 'michael.rueger@squeakland.org' subject: 'test subject' body: 'message' " | mailTo | mailTo _ WriteStream on: String new. mailTo nextPutAll: 'mailto:'. mailTo nextPutAll: address; nextPut: $?. subject isEmptyOrNil ifFalse: [mailTo nextPutAll: 'subject='; nextPutAll: subject; nextPut: $&]. body isEmptyOrNil ifFalse: [mailTo nextPutAll: 'body='; nextPutAll: body]. self httpGet: mailTo contents! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43'! getDirectoryListing: dirListURL "HTTPClient getDirectoryListing: 'http://www.squeakalpha.org/uploads' " | answer ftpEntries | " answer _ self httpPostDocument: dirListURL args: Dictionary new." "Workaround for Mac IE problem" answer _ self httpGetDocument: dirListURL. answer isString ifTrue: [^self error: 'Listing failed: ' , answer] ifFalse: [answer _ answer content]. answer first == $< ifTrue: [self error: 'Listing failed: ' , answer]. ftpEntries _ answer findTokens: String crlf. ^ ftpEntries collect:[:ftpEntry | ServerDirectory parseFTPEntry: ftpEntry] thenSelect: [:entry | entry notNil]! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/1/2001 12:51'! mailTo: address message: aString HTTPClient shouldUsePluginAPI ifFalse: [^self error: 'You need to run inside a web browser.']. FileStream post: aString url: 'mailto:' , address ifError: [self error: 'Can not send mail']! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 5/13/2003 10:43'! tellAFriend: emailAddressOrNil url: urlForLoading name: projectName | recipient subject body linkToInclude | recipient _ emailAddressOrNil ifNil: ['RECIPIENT.GOESHERE']. subject _ 'New/Updated Squeak project'. body _ 'This is a link to the Squeak project ' , projectName , ': ' , String crlf. linkToInclude _ urlForLoading. HTTPClient shouldUsePluginAPI ifTrue: [ self composeMailTo: recipient subject: subject body: body , (linkToInclude copyReplaceAll: '%' with: '%25')] ifFalse: [Preferences allowCelesteTell ifTrue: [FancyMailComposition new celeste: nil to: recipient subject: subject initialText: body theLinkToInclude: linkToInclude; open] ifFalse: [self inform: 'You need to run inside a web browser to use the tell function.']]! ! !HTTPClient class methodsFor: 'utilities' stamp: 'mir 2/2/2001 17:59'! uploadFileNamed: aFilename to: baseUrl user: user passwd: passwd | fileContents remoteFilename | remoteFilename _ (baseUrl endsWith: '/') ifTrue: [baseUrl , '/' , aFilename] ifFalse: [baseUrl , aFilename]. fileContents _ (StandardFileStream readOnlyFileNamed: aFilename) contentsOfEntireFile. HTTPSocket httpPut: fileContents to: remoteFilename user: user passwd: passwd! ! !HTTPClient class methodsFor: 'testing' stamp: 'ccn 3/14/2001 19:56'! isRunningInBrowser RunningInBrowser isNil ifTrue: [self determineIfRunningInBrowser]. ^RunningInBrowser! ! !HTTPClient class methodsFor: 'testing' stamp: 'mir 8/4/2003 13:44'! isRunningInBrowser: aBoolean "Override the automatic process. This should be used with caution. One way to determine it without using the primitive is to check for parameters typically only encountered when running as a plugin." RunningInBrowser := aBoolean! ! !HTTPClient class methodsFor: 'testing' stamp: 'sd 9/30/2003 13:56'! shouldUsePluginAPI "HTTPClient shouldUsePluginAPI" self isRunningInBrowser ifFalse: [^false]. self browserSupportsAPI ifFalse: [^false]. "The Mac plugin calls do not work in full screen mode" ^((SmalltalkImage current platformName = 'Mac OS') and: [ScreenController lastScreenModeSelected]) not! ! !HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:43'! exampleMailTo "HTTPClient exampleMailTo" HTTPClient mailTo: 'm.rueger@acm.org' message: 'A test message from within Squeak' ! ! !HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:43'! examplePostArgs "HTTPClient examplePostArgs" | args result resultStream | args _ Dictionary new. args at: 'arg1' put: #('val1'); at: 'arg2' put: #('val2'); yourself. resultStream _ HTTPClient httpPostDocument: 'http://www.squeaklet.com/cgi-bin/thrd.pl' args: args. result _ resultStream upToEnd. Transcript show: result; cr; cr. resultStream close ! ! !HTTPClient class methodsFor: 'examples' stamp: 'mir 2/2/2001 17:44'! examplePostMultipart "HTTPClient examplePostMultipart" | args result | args _ Dictionary new. args at: 'arg1' put: #('val1'); at: 'arg2' put: #('val2'); yourself. result _ HTTPClient httpPostMultipart: 'http://www.squeaklet.com/cgi-bin/thrd.pl' args: args. Transcript show: result content; cr; cr. ! ! !HTTPClient class methodsFor: 'post/get' stamp: 'nk 8/30/2004 07:50'! httpGet: url | document | document _ self httpGetDocument: url. ^(document isString) ifTrue: [ "strings indicate errors" document] ifFalse: [(RWBinaryOrTextStream with: document content) reset]! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/11/2001 12:55'! httpGetDocument: url | stream content | ^self shouldUsePluginAPI ifTrue: [ stream _ FileStream requestURLStream: url ifError: [self error: 'Error in get from ' , url printString]. stream ifNil: [^'']. stream position: 0. content _ stream upToEnd. stream close. MIMEDocument content: content] ifFalse: [HTTPSocket httpGetDocument: url]! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:04'! httpPostDocument: url args: argsDict ^self httpPostDocument: url target: nil args: argsDict! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 15:06'! httpPostDocument: url target: target args: argsDict | argString stream content | ^self shouldUsePluginAPI ifTrue: [ argString _ argsDict ifNotNil: [argString _ HTTPSocket argString: argsDict] ifNil: ['']. stream _ FileStream post: argString , ' ' target: target url: url , argString ifError: [self error: 'Error in post to ' , url printString]. stream position: 0. content _ stream upToEnd. stream close. MIMEDocument content: content] ifFalse: [HTTPSocket httpPostDocument: url args: argsDict]! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 5/1/2001 12:51'! httpPostMultipart: url args: argsDict " do multipart/form-data encoding rather than x-www-urlencoded " ^self shouldUsePluginAPI ifTrue: [self pluginHttpPostMultipart: url args: argsDict] ifFalse: [HTTPSocket httpPostMultipart: url args: argsDict accept: nil request: '']! ! !HTTPClient class methodsFor: 'post/get' stamp: 'mir 4/2/2002 15:52'! requestURL: url target: target ^self shouldUsePluginAPI ifTrue: [FileStream requestURL: url target: target] ifFalse: [self error: 'Requesting a new URL target is not supported.']! ! !HTTPClient class methodsFor: 'private' stamp: 'mir 5/13/2003 10:43'! pluginHttpPostMultipart: url args: argsDict | mimeBorder argsStream crLf fieldValue resultStream result | " do multipart/form-data encoding rather than x-www-urlencoded " crLf _ String crlf. mimeBorder _ '----squeak-', Time millisecondClockValue printString, '-stuff-----'. "encode the arguments dictionary" argsStream _ WriteStream on: String new. argsDict associationsDo: [:assoc | assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, crLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue _ value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', crLf, 'Content-Type: ', value contentType. fieldValue _ (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: crLf, crLf, fieldValue, crLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. resultStream _ FileStream post: ('ACCEPT: text/html', crLf, 'User-Agent: Squeak 3.1', crLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, crLf, 'Content-length: ', argsStream contents size printString, crLf, crLf, argsStream contents) url: url ifError: [^'Error in post ' url toText]. "get the header of the reply" result _ resultStream ifNil: [''] ifNotNil: [resultStream upToEnd]. ^MIMEDocument content: result! ! !HTTPDownloadRequest methodsFor: 'accessing' stamp: 'ar 5/30/2001 21:03'! contentStream "Return a stream on the content of a previously completed HTTP request" semaphore wait. ^content ifNotNil:[content contentStream]! ! !HTTPDownloadRequest methodsFor: 'initialize'! for: aUrl in: aLoader url _ self httpEncodeSafely: aUrl. loader _ aLoader. semaphore _ Semaphore new.! ! !HTTPDownloadRequest methodsFor: 'testing' stamp: 'ar 3/2/2001 16:53'! isSemaphoreSignaled "Return true if the associated semaphore is currently signaled. This information can be used to determine whether the download has finished given that there is no other process waiting on the semaphore." ^semaphore isSignaled! ! !HTTPDownloadRequest methodsFor: 'private' stamp: 'mir 3/16/2001 13:07'! httpEncodeSafely: aUrl "Encode the url but skip $/ and $:." | encodedStream unescaped | unescaped _ aUrl unescapePercents. encodedStream _ WriteStream on: (String new). unescaped do: [ :c | (c isSafeForHTTP or: [c == $/ or: [c == $:]]) ifTrue: [ encodedStream nextPut: c ] ifFalse: [ encodedStream nextPut: $%. encodedStream nextPut: (c asciiValue // 16) asHexDigit. encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. ] ]. ^encodedStream contents. ! ! !HTTPLoader methodsFor: 'private' stamp: 'md 11/14/2003 16:38'! removeProcess: downloadProcess downloads remove: downloadProcess ifAbsent: []! ! !HTTPLoader methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! startDownload | newDownloadProcess | downloads size >= self maxNrOfConnections ifTrue: [^self]. requests size <= 0 ifTrue: [^self]. newDownloadProcess _ [ [ self nextRequest startRetrieval ] on: FTPConnectionException do: [ :ex | Cursor normal show. self removeProcess: Processor activeProcess. self startDownload ]. self removeProcess: Processor activeProcess. self startDownload ] newProcess. downloads add: newDownloadProcess. newDownloadProcess resume! ! !HTTPLoader methodsFor: 'requests' stamp: 'mir 4/16/2001 17:48'! retrieveContentsFor: url | request | request _ self class httpRequestClass for: url in: self. self addRequest: request. ^request contents! ! !HTTPLoader methodsFor: 'requests' stamp: 'nk 8/30/2004 07:50'! retrieveObjectsFor: aURL "Load a remote image segment and extract the root objects. Check if the remote file is a zip archive." "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.extSeg' asUrl loadRemoteObjects" "'http://bradley.online.disney.com/games/subgame/squeak-test/assetInfo.zip' asUrl loadRemoteObjects" | stream info data | data _ self retrieveContentsFor: aURL. (data isString) ifTrue: [^self error: data] ifFalse: [data _ data content]. (data beginsWith: 'error') ifTrue: [^self error: data]. data _ data unzipped. stream _ RWBinaryOrTextStream on: data. stream reset. info _ stream fileInObjectAndCode. stream close. ^info originalRoots! ! !HTTPLoader class methodsFor: 'class initialization' stamp: 'mir 3/8/2001 16:31'! initialize "HTTPLoader initialize" MaxNrOfConnections _ 4. DefaultLoader ifNotNil: [ DefaultLoader release. DefaultLoader _ nil]! ! !HTTPLoader class methodsFor: 'accessing' stamp: 'avi 4/30/2004 01:40'! httpRequestClass ^HTTPClient shouldUsePluginAPI ifTrue: [PluginHTTPDownloadRequest] ifFalse: [HTTPDownloadRequest]! ! !HTTPProxyEditor methodsFor: 'accessing' stamp: 'dgd 10/29/2003 13:44'! port "answer the receiver's port" ^ port! ! !HTTPProxyEditor methodsFor: 'accessing' stamp: 'dgd 10/29/2003 13:44'! port: anInteger "change the receiver's port" port := anInteger. self changed: #port! ! !HTTPProxyEditor methodsFor: 'accessing' stamp: 'dgd 10/29/2003 13:44'! serverName "answer the receiver's serverName" ^ serverName! ! !HTTPProxyEditor methodsFor: 'accessing' stamp: 'dgd 10/29/2003 13:44'! serverName: aString "change the receiver's serverName" serverName := aString. self changed: #serverName! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 14:19'! createButtonLabel: aString action: actionSelector help: helpString "private - create a button for the receiver" | button | button := SimpleButtonMorph new target: self; label: aString translated; actionSelector: actionSelector; setBalloonText: helpString translated; borderWidth: 2; useSquareCorners. "" ^ button! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 13:57'! createLabel: aString "private - create a label with aString" | labelWidget | labelWidget := PluggableButtonMorph on: self getState: nil action: nil. labelWidget hResizing: #spaceFill; vResizing: #spaceFill; label: aString translated. "" labelWidget onColor: Color transparent offColor: Color transparent. "" ^ labelWidget! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 14:20'! createText: selector "private - create a text widget on selector" | widget | widget := PluggableTextMorph on: self text: selector accept: (selector , ':') asSymbol. widget acceptOnCR: true. ^ widget! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 14:13'! initialize "initialize the receiver" super initialize. "" serverName := HTTPSocket httpProxyServer ifNil: ['']. port := HTTPSocket httpProxyPort asString. "" self setLabel: 'HTTP Proxy Editor' translated. self setWindowColor: (Color r: 0.9 g: 0.8 b: 1.0). "" self initializeWidgets. self updateWidgets. "" self extent: 300@180! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 14:03'! initializeWidgets "initialize the receiver's widgets" self addMorph: (serverNameLabelWidget := self createLabel: 'Server Name:') frame: (0 @ 0 corner: 0.5 @ 0.33). self addMorph: (serverNameWidget := self createText: #serverName) frame: (0.5 @ 0 corner: 1 @ 0.33). "" self addMorph: (portLabelWidget := self createLabel: 'Port:') frame: (0 @ 0.33 corner: 0.5 @ 0.67). self addMorph: (portWidget := self createText: #port) frame: (0.5 @ 0.33 corner: 1 @ 0.67). "" self addMorph: (acceptWidget := self createButtonLabel: 'Accept' action: #accept help: 'Accept the proxy settings') frame: (0 @ 0.67 corner: 0.5 @ 1). self addMorph: (cancelWidget := self createButtonLabel: 'Cancel' action: #cancel help: 'Cancel the proxy settings') frame: (0.5 @ 0.67 corner: 1 @ 1)! ! !HTTPProxyEditor methodsFor: 'initialization' stamp: 'dgd 10/29/2003 14:20'! updateWidgets "update the receiver's widgets" acceptWidget isNil ifFalse: ["" acceptWidget color: Color lightGreen; borderWidth: 2; borderColor: #raised]. cancelWidget isNil ifFalse: ["" cancelWidget color: Color lightRed; borderWidth: 2; borderColor: #raised]. "" serverNameLabelWidget isNil ifFalse: ["" serverNameLabelWidget color: self paneColor lighter; borderColor: #raised]. portLabelWidget isNil ifFalse: ["" portLabelWidget color: self paneColor lighter; borderColor: #raised]! ! !HTTPProxyEditor methodsFor: 'open/close' stamp: 'dgd 10/29/2003 14:21'! initialExtent "answer the receiver's initialExtent" ^ 300 @ 180! ! !HTTPProxyEditor methodsFor: 'panes' stamp: 'dgd 10/29/2003 14:20'! paneColor: aColor "the pane color was changed" super paneColor: aColor. "" self updateWidgets! ! !HTTPProxyEditor methodsFor: 'user interface' stamp: 'dgd 10/29/2003 14:30'! accept "the user press the [accept] button" serverNameWidget hasUnacceptedEdits ifTrue: [serverNameWidget accept]. portWidget hasUnacceptedEdits ifTrue: [portWidget accept]. "" self applyChanges. "" self delete! ! !HTTPProxyEditor methodsFor: 'user interface' stamp: 'dgd 10/29/2003 14:39'! applyChanges "apply the changes on HTTPSocket" | finalServerName finalPort | finalServerName := serverName asString withBlanksTrimmed. [finalPort := port asString withBlanksTrimmed asNumber] on: Error do: [:ex | finalPort := 0]. "" (finalServerName isNil or: [finalServerName isEmpty] or: [finalPort isZero]) ifTrue: ["" Transcript show: ('Stop using Proxy Server.' translated ); cr. "" HTTPSocket stopUsingProxyServer. ^ self]. "" Transcript show: ('Proxy Server Named: ''{1}'' port: {2}.' translated format: {finalServerName. finalPort}); cr. HTTPSocket useProxyServerNamed: finalServerName port: finalPort! ! !HTTPProxyEditor methodsFor: 'user interface' stamp: 'dgd 10/29/2003 14:18'! cancel "the user press the [cancel] button" self delete! ! !HTTPProxyEditor commentStamp: 'dgd 10/29/2003 14:29' prior: 0! An editor for the http proxy settings. To open it evaluate: HTTPProxyEditor open. or use the World Menu (open... >> http proxy editor). ! ]style[(63 21 56)f3cblack;,f3dHTTPProxyEditor open.;;,f3cblack;! !HTTPProxyEditor class methodsFor: 'class initialization' stamp: 'asm 10/30/2003 19:42'! initialize self registerInOpenMenu! ! !HTTPProxyEditor class methodsFor: 'class initialization' stamp: 'dgd 10/29/2003 14:25'! registerInOpenMenu "Register the receiver in the system's open menu" TheWorldMenu registerOpenCommand: {'http proxy editor'. {HTTPProxyEditor. #open}. 'An editor for the http proxy settings'}! ! !HTTPProxyEditor class methodsFor: 'class initialization' stamp: 'asm 10/30/2003 19:42'! unload "Called when the class is being removed" TheWorldMenu unregisterOpenCommandWithReceiver: self! ! !HTTPProxyEditor class methodsFor: 'instance creation' stamp: 'dgd 10/29/2003 14:27'! activateWindow: aWindow "private - activate the window" aWindow right: (aWindow right min: World bounds right). aWindow bottom: (aWindow bottom min: World bounds bottom). aWindow left: (aWindow left max: World bounds left). aWindow top: (aWindow top max: World bounds top). "" aWindow comeToFront. aWindow flash! ! !HTTPProxyEditor class methodsFor: 'instance creation' stamp: 'dgd 10/29/2003 14:26'! open "open the receiver" World submorphs do: [:each | "" ((each isKindOf: self) ) ifTrue: ["" self activateWindow: each. ^ self]]. "" ^ self new openInWorld! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:44'! directoryNames | dirNames projectNames entries | "Return a collection of names for the subdirectories of this directory but filter out project directories." entries _ self entries. dirNames _ (entries select: [:entry | entry at: 4]) collect: [:entry | entry first]. projectNames _ Set new. entries do: [:entry | ((entry at: 4) not and: ['*.pr' match: entry first]) ifTrue: [projectNames add: (entry first copyFrom: 1 to: entry first size-3)]]. ^dirNames reject: [:each | projectNames includes: each] ! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:43'! entries ^HTTPClient getDirectoryListing: self dirListUrl! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/20/2001 18:26'! fileNames "Return a collection of names for the files (but not directories) in this directory." "(ServerDirectory serverNamed: 'UIUCArchive') fileNames" self dirListUrl ifNil: [^self error: 'No URL set for fetching the directory listing.' ]. ^(self entries select: [:entry | (entry at: 4) not]) collect: [:entry | entry first] ! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 4/16/2001 17:54'! oldFileNamed: aName | contents | contents _ HTTPLoader default retrieveContentsFor: (self altUrl , '/' , aName). ^(SwikiPseudoFileStream with: contents content) reset; directory: self; localName: aName; yourself ! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 6/5/2001 16:40'! pathName "Path name as used in reading the file. with slashes for ftp, with local file delimiter (:) for a file: url" urlObject ifNotNil: [^ urlObject pathForFile]. directory size = 0 ifTrue: [^ server]. ^(directory at: 1) = self pathNameDelimiter ifTrue: [server, directory] ifFalse: [user ifNil: [server, self pathNameDelimiter asString, directory] ifNotNil: [user, '@', server, self pathNameDelimiter asString, directory]]! ! !HTTPServerDirectory methodsFor: 'file directory' stamp: 'mir 5/30/2001 19:55'! readOnlyFileNamed: aName ^self oldFileNamed: aName! ! !HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 5/3/2001 12:58'! dirListUrl | listURL | listURL _ self altUrl. listURL last ~= $/ ifTrue: [listURL _ listURL , '/']. ^ listURL! ! !HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 4/16/2001 18:02'! directoryNamed: localFileName | newDir | newDir _ super directoryNamed: localFileName. newDir altUrl: (self altUrl , '/' , localFileName). ^newDir! ! !HTTPServerDirectory methodsFor: 'accessing' stamp: 'mir 6/25/2001 17:17'! typeForPrefs ^'http'! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 13:55'! getResponseUpTo: markerString "Keep reading until the marker is seen. Return three parts: header, marker, beginningOfData. Fails if no marker in first 2000 chars." | buf response bytesRead tester mm tries | buf _ String new: 2000. response _ WriteStream on: buf. tester _ 1. mm _ 1. tries _ 3. [tester _ tester - markerString size + 1 max: 1. "rewind a little, in case the marker crosses a read boundary" tester to: response position do: [:tt | (buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1]. "Not totally correct for markers like xx0xx" mm > markerString size ifTrue: ["got it" ^ Array with: (buf copyFrom: 1 to: tt+1-mm) with: markerString with: (buf copyFrom: tt+1 to: response position)]]. tester _ 1 max: response position. "OK if mm in the middle" (response position < buf size) & (self isConnected | self dataAvailable) & ((tries _ tries - 1) >= 0)] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: ' ']. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: response position + 1 count: buf size - response position. "response position+1 to: response position+bytesRead do: [:ii | response nextPut: (buf at: ii)]. totally redundant, but needed to advance position!!" response instVarAt: 2 "position" put: (response position + bytesRead)]. "horrible, but fast" ^ Array with: response contents with: '' with: '' "Marker not found and connection closed" ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 20:13'! getRestOfBuffer: beginning "We don't know the length. Keep going until connection is closed. Part of it has already been received. Response is of type text, not binary." | buf response bytesRead | response _ RWBinaryOrTextStream on: (String new: 2000). response nextPutAll: beginning. buf _ String new: 2000. [self isConnected | self dataAvailable] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: 'data was slow'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. bytesRead > 0 ifTrue: [ response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ]. self logToTranscript ifTrue: [ Transcript cr; show: 'data byte count: ', response position printString]. response reset. "position: 0." ^ response ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:39'! header: headerText "set the headers. Then getHeader: can be used" "divide into basic lines" | lines foldedLines i statusLine | lines _ headerText findTokens: (String with: Character cr with: Character linefeed). statusLine _ lines first. lines _ lines copyFrom: 2 to: lines size. "parse the status (pretty trivial right now)" responseCode _ (statusLine findTokens: ' ') second. "fold lines that start with spaces into the previous line" foldedLines _ OrderedCollection new. lines do: [ :line | line first isSeparator ifTrue: [ foldedLines at: foldedLines size put: (foldedLines last, line) ] ifFalse: [ foldedLines add: line ] ]. "make a dictionary mapping headers to header contents" headers _ Dictionary new. foldedLines do: [ :line | i _ line indexOf: $:. i > 0 ifTrue: [ headers at: (line copyFrom: 1 to: i-1) asLowercase put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ]. ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'hg 2/11/2002 19:47'! logToTranscript ^LogToTranscript == true! ! !HTTPSocket class methodsFor: 'class initialization' stamp: 'al 1/8/2004 12:21'! initialize "HTTPSocket initialize" ParamDelimiters _ ' ', CrLf. HTTPPort _ 80. HTTPProxyServer _ nil. HTTPBlabEmail _ ''. " 'From: somebody@no.where', CrLf " HTTPProxyCredentials _ ''. ExternalSettings registerClient: self! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sw 5/23/2001 13:44'! httpFileIn: url "Do a regular file-in of a file that is served from a web site. If the file contains an EToy, then open it. Might just be code instead. tk 7/23/97 17:10" "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones. The server does not have to know about the .sqo extension in order to send your file. (We do not need a new MIME type and .sqo does not have to be registered with the server.)" " HTTPSocket httpFileIn: 'www.webPage.com/~kaehler2/sample.etoy' " " HTTPSocket httpFileIn: '206.18.68.12/squeak/car.sqo' " " HTTPSocket httpFileIn: 'jumbo/tedk/sample.etoy' " | doc eToyHolder | doc _ self httpGet: url accept: 'application/octet-stream'. doc class == String ifTrue: [self inform: 'Cannot seem to contact the web site']. doc reset. eToyHolder _ doc fileInObjectAndCode. eToyHolder ifNotNil: [eToyHolder open]. "Later may want to return it, instead of open it" ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sw 5/23/2001 13:44'! httpFileInNewChangeSet: url "Do a regular file-in of a file that is served from a web site. Put it into a new changeSet." "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones." " HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs' " | doc | doc _ self httpGet: url accept: 'application/octet-stream'. doc class == String ifTrue: [self inform: 'Cannot seem to contact the web site']. doc reset. ChangeSorter newChangesFromStream: doc named: (url findTokens: '/') last.! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:36'! httpGet: url "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " " HTTPSocket httpShowPage: 'www.apple.com/default.html' " " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " ^ self httpGet: url accept: '*/*' ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 12/7/2001 17:37'! httpGet: url accept: mimeType "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. Note: To fetch raw data, you can use the MIME type 'application/octet-stream'. To accept anything, use '*/*'." ^self httpGet: url args: nil accept: mimeType! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'hg 2/12/2002 11:39'! httpGet: url args: args accept: mimeType ^self httpGet: url args: args accept: mimeType request: ''! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'! httpGet: url args: args accept: mimeType request: requestString "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." | document | document _ self httpGetDocument: url args: args accept: mimeType request: requestString. (document isString) ifTrue: [ "strings indicate errors" ^ document ]. ^ (RWBinaryOrTextStream with: document content) reset ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'! httpGetNoError: url args: args accept: mimeType "Return the exact contents of a web file. Do better error checking. Asks for the given MIME type. To fetch raw data, you can use the MIMI type 'application/octet-stream'. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered." "Edited to remove a lineFeed from the source 4/4/99 - di" | document data | document _ self httpGetDocument: url args: args accept: mimeType. (document isString) ifTrue: [ "strings indicate errors" ^ document ]. data _ document content. (data beginsWith: '' , (String with: Character linefeed) , '4') ifTrue: ["an error message 404 File not found" ^ data copyFrom: 21 to: data size-16]. ^ (RWBinaryOrTextStream with: data) reset ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:36'! httpGif: url "Fetch the given URL, parse it using the GIF reader, and return the resulting Form." " HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif' " " HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif' " | doc ggg | doc _ self httpGet: url accept: 'image/gif'. doc class == String ifTrue: [ self inform: 'The server with that GIF is not responding'. ^ ColorForm extent: 20@20 depth: 8]. doc binary; reset. (ggg _ GIFReadWriter new) setStream: doc. ^ ggg nextImage. ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'nk 7/7/2003 18:37'! httpJpeg: url "Fetch the given URL, parse it using the JPEG reader, and return the resulting Form." | doc ggg | doc _ self httpGet: url. doc binary; reset. (ggg _ JPEGReadWriter new) setStream: doc. ^ ggg nextImage. ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'nk 8/30/2004 07:50'! httpPost: url args: argsDict accept: mimeType "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" | document | document _ self httpPostDocument: url args: argsDict accept: mimeType request: ''. (document isString) ifTrue: [ "strings indicate errors" ^document ]. ^RWBinaryOrTextStream with: document content! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'daf 2/28/2004 18:56'! httpPostDocument: url args: argsDict accept: mimeType request: requestString "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" | s header length page list firstData aStream type newUrl httpUrl argString | Socket initializeNetwork. httpUrl _ Url absoluteFromText: url. page _ httpUrl fullPath. "add arguments" argString _ argsDict ifNotNil: [argString _ self argString: argsDict] ifNil: ['']. page _ page, argString. s _ HTTPSocket new. s _ self initHTTPSocket: httpUrl wait: (self deadlineSecs: 30) ifError: [:errorString | ^errorString]. s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPProxyCredentials, HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" self userAgentString, CrLf, 'Content-type: application/x-www-form-urlencoded', CrLf, 'Content-length: ', argString size printString, CrLf, 'Host: ', httpUrl authority, CrLf. "blank line automatically added" argString first = $? ifTrue: [ argString _ argString copyFrom: 2 to: argString size]. "umur - IE sends argString without a $? and swiki expects so" s sendCommand: argString. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ newUrl _ s getHeader: 'location'. newUrl ifNotNil: [ "umur 6/25/2003 12:58 - If newUrl is relative then we need to make it absolute." newUrl _ (httpUrl newFromRelativeText: newUrl) asString. self flag: #refactor. "get, post, postmultipart are almost doing the same stuff" s destroy. "^self httpPostDocument: newUrl args: argsDict accept: mimeType" ^self httpGetDocument: newUrl accept: mimeType ] ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ]style[(77 693 21 303 150 561 228 369)f1b,f1,f2,f1,f1cmagenta;,f1,f1cmagenta;,f1! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'daf 2/28/2004 18:58'! httpPostMultipart: url args: argsDict accept: mimeType request: requestString " do multipart/form-data encoding rather than x-www-urlencoded " " by Bolot Kerimbaev, 1998 " " this version is a memory hog: puts the whole file in memory " "bolot 12/14/2000 18:28 -- minor fixes to make it comply with RFC 1867" | serverName serverAddr s header length bare page list firstData aStream port argsStream specifiedServer type newUrl mimeBorder fieldValue | Socket initializeNetwork. "parse url" bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName _ bare copyUpTo: $/. specifiedServer _ serverName. (serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [ port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName _ serverName copyUpTo: $:. ]. page _ bare copyFrom: (bare indexOf: $/) to: bare size. page size = 0 ifTrue: [page _ '/']. (self shouldUseProxy: serverName) ifTrue: [ page _ 'http://', serverName, ':', port printString, page. "put back together" serverName _ HTTPProxyServer. port _ HTTPProxyPort]. mimeBorder _ '----squeak-georgia-tech-', Time millisecondClockValue printString, '-csl-cool-stuff-----'. "encode the arguments dictionary" argsStream _ WriteStream on: String new. argsDict associationsDo: [:assoc | assoc value do: [ :value | "print the boundary" argsStream nextPutAll: '--', mimeBorder, CrLf. " check if it's a non-text field " argsStream nextPutAll: 'Content-disposition: multipart/form-data; name="', assoc key, '"'. (value isKindOf: MIMEDocument) ifFalse: [fieldValue _ value] ifTrue: [argsStream nextPutAll: ' filename="', value url pathForFile, '"', CrLf, 'Content-Type: ', value contentType. fieldValue _ (value content ifNil: [(FileStream fileNamed: value url pathForFile) contentsOfEntireFile] ifNotNil: [value content]) asString]. " Transcript show: 'field=', key, '; value=', fieldValue; cr. " argsStream nextPutAll: CrLf, CrLf, fieldValue, CrLf. ]]. argsStream nextPutAll: '--', mimeBorder, '--'. "make the request" serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ifNil: [ ^ 'Could not resolve the server named: ', serverName]. s _ HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. Transcript cr; show: serverName, ':', port asString; cr. s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPProxyCredentials, HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" self userAgentString, CrLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, 'Content-length: ', argsStream contents size printString, CrLf, 'Host: ', specifiedServer, CrLf. "blank line automatically added" s sendCommand: argsStream contents. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf. "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ "redirected - don't re-post automatically" "for now, just do a GET, without discriminating between 301/302 codes" newUrl _ s getHeader: 'location'. newUrl ifNotNil: [ (newUrl beginsWith: 'http://') ifFalse: [ (newUrl beginsWith: '/') ifTrue: [newUrl _ (bare copyUpTo: $/), newUrl] ifFalse: [newUrl _ url, newUrl. self flag: #todo "should do a relative URL"] ]. Transcript show: 'redirecting to: ', newUrl; cr. s destroy. ^self httpGetDocument: newUrl "for some codes, may do: ^self httpPostMultipart: newUrl args: argsDict accept: mimeType request: requestString"] ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'daf 2/28/2004 18:58'! httpPostToSuperSwiki: url args: argsDict accept: mimeType request: requestString | serverName serverAddr s header length bare page list firstData aStream port specifiedServer type mimeBorder contentsData | Socket initializeNetwork. "parse url" bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName _ bare copyUpTo: $/. specifiedServer _ serverName. (serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [ port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName _ serverName copyUpTo: $:. ]. page _ bare copyFrom: (bare indexOf: $/ ifAbsent: [^'error']) to: bare size. page size = 0 ifTrue: [page _ '/']. (self shouldUseProxy: serverName) ifTrue: [ page _ 'http://', serverName, ':', port printString, page. "put back together" serverName _ HTTPProxyServer. port _ HTTPProxyPort]. mimeBorder _ '---------SuperSwiki',Time millisecondClockValue printString,'-----'. contentsData _ String streamContents: [ :strm | strm nextPutAll: mimeBorder, CrLf. argsDict associationsDo: [:assoc | assoc value do: [ :value | strm nextPutAll: 'Content-disposition: form-data; name="', assoc key, '"'; nextPutAll: CrLf; nextPutAll: CrLf; nextPutAll: value; nextPutAll: CrLf; nextPutAll: CrLf; nextPutAll: mimeBorder; nextPutAll: CrLf. ] ]. ]. "make the request" serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ifNil: [ ^ 'Could not resolve the server named: ', serverName]. s _ HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. s sendCommand: 'POST ', page, ' HTTP/1.1', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPProxyCredentials, HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" self userAgentString, CrLf, 'Content-type: multipart/form-data; boundary=', mimeBorder, CrLf, 'Content-length: ', contentsData size printString, CrLf, 'Host: ', specifiedServer, CrLf. "blank line automatically added" s sendCommand: contentsData. list _ s getResponseUpTo: CrLf, CrLf. "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. firstData _ list at: 3. header isEmpty ifTrue: [ s destroy. ^'no response' ]. s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'al 1/8/2004 12:50'! httpPut: contents to: url user: user passwd: passwd "Upload the contents of the stream to a file on the server" | bare serverName specifiedServer port page serverAddr authorization s list header firstData length aStream command | Socket initializeNetwork. "parse url" bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName _ bare copyUpTo: $/. specifiedServer _ serverName. (serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [ port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName _ serverName copyUpTo: $:. ]. page _ bare copyFrom: (bare indexOf: $/) to: bare size. page size = 0 ifTrue: [page _ '/']. (self shouldUseProxy: serverName) ifTrue: [ page _ 'http://', serverName, ':', port printString, page. "put back together" serverName _ HTTPProxyServer. port _ HTTPProxyPort]. "make the request" serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ifNil: [ ^ 'Could not resolve the server named: ', serverName]. authorization _ (Base64MimeConverter mimeEncode: (user , ':' , passwd) readStream) contents. s _ HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. Transcript cr; show: url; cr. command _ 'PUT ', page, ' HTTP/1.0', CrLf, self userAgentString, CrLf, 'Host: ', specifiedServer, CrLf, 'ACCEPT: */*', CrLf, HTTPProxyCredentials, 'Authorization: Basic ' , authorization , CrLf , 'Content-length: ', contents size printString, CrLf , CrLf , contents. s sendCommand: command. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s destroy. "Always OK to destroy!!" ^ header, aStream contents! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 8/23/2002 14:28'! fetchExternalSettingsIn: aDirectory "Scan for server configuration files" "HTTPSocket fetchExternalSettingsIn: (FileDirectory default directoryNamed: 'prefs')" | stream entries | (aDirectory fileExists: self proxySettingsFileName) ifFalse: [^self]. stream _ aDirectory readOnlyFileNamed: self proxySettingsFileName. stream ifNotNil: [ [entries _ ExternalSettings parseServerEntryArgsFrom: stream] ensure: [stream close]]. entries ifNil: [^self]. HTTPProxyServer _ entries at: 'host' ifAbsent: [nil]. HTTPProxyPort _ (entries at: 'port' ifAbsent: ['80']) asInteger ifNil: [self defaultPort]. HTTPSocket addProxyException: (entries at: 'exception' ifAbsent: [nil])! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'dgd 10/29/2003 14:21'! httpProxyPort "answer the httpProxyPort" ^ HTTPProxyPort! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'dgd 10/29/2003 14:21'! httpProxyServer "answer the httpProxyServer" ^ HTTPProxyServer! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'mir 8/23/2002 14:29'! proxySettingsFileName ^'proxySettings'! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:27'! proxyUser: userName password: password "Store HTTP 1.0 basic authentication credentials Note: this is an ugly hack that stores your password in your image. It's just enought to get you going if you use a firewall that requires authentication" | stream encodedStream | stream _ ReadWriteStream on: (String new: 16). stream nextPutAll: userName ,':' , password. encodedStream _ Base64MimeConverter mimeEncode: stream. HTTPProxyCredentials _ 'Proxy-Authorization: Basic ' , (encodedStream contents) , String crlf! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:27'! stopUsingProxyServer "Stop directing HTTP request through a proxy server." HTTPProxyServer _ nil. HTTPProxyPort _ 80. HTTPProxyCredentials _ '' ! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'yo 4/1/2004 22:02'! useProxyServerNamed: proxyServerName port: portNum "Direct all HTTP requests to the HTTP proxy server with the given name and port number." proxyServerName ifNil: [ "clear proxy settings" HTTPProxyServer _ nil. HTTPProxyPort _ 80. ^ self]. proxyServerName class == String ifFalse: [self error: 'Server name must be a String or nil']. HTTPProxyServer _ proxyServerName. HTTPProxyPort _ portNum. HTTPProxyPort class == String ifTrue: [HTTPProxyPort _ portNum asNumber]. HTTPProxyPort ifNil: [HTTPProxyPort _ self defaultPort].! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'al 1/8/2004 12:54'! useProxyServerNamed: proxyServerName port: portNum proxyUser: aString password: anotherString self useProxyServerNamed: proxyServerName port: portNum. self proxyUser: aString password: anotherString! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'tk 12/7/2001 12:24'! expandUrl: newUrl ip: byteArrayIP port: portNum ^ (newUrl beginsWith: '../') ifTrue: [ String streamContents: [:strm | byteArrayIP do: [:bb | bb printOn: strm. strm nextPut: $.]. strm skip: -1; nextPut: $:. portNum printOn: strm. strm nextPutAll: (newUrl allButFirst: 2)]] ifFalse: [newUrl]! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'ls 11/3/2002 14:05'! initHTTPSocket: httpUrl wait: timeout ifError: aBlock "Retrieve the server and port information from the URL, match it to the proxy settings and open a http socket for the request." | serverName port serverAddr s | Socket initializeNetwork. serverName _ httpUrl authority. port _ httpUrl port ifNil: [self defaultPort]. (self shouldUseProxy: serverName) ifTrue: [ serverName _ HTTPProxyServer. port _ HTTPProxyPort]. "make the request" serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ifNil: [ aBlock value: 'Error: Could not resolve the server named: ', serverName]. s _ HTTPSocket new. s connectTo: serverAddr port: port. (s waitForConnectionUntil: timeout) ifFalse: [ Socket deadServer: httpUrl authority. s destroy. ^aBlock value: 'Error: Server ',httpUrl authority,' is not responding']. ^s ! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'nk 4/13/2002 13:00'! retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock "Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false." | response | [tryBlock value] whileFalse: [ | sema | sema _ Semaphore new. WorldState addDeferredUIMessage: [ response _ (PopUpMenu labels: 'Retry\Give Up' withCRs) startUpWithCaption: troubleString. sema signal. ]. sema wait. response = 2 ifTrue: [abortActionBlock value. ^ false]]. ^ true ! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'nk 6/12/2004 09:24'! showImage: image named: imageName Smalltalk isMorphic ifTrue: [HandMorph attach: (World drawingClass withForm: image)] ifFalse: [FormView open: image named: imageName]! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'hg 2/11/2002 11:31'! userAgentString "self userAgentString" ^'User-Agent: ', SystemVersion current version, '-', SystemVersion current highestUpdate printString! ! !HTTPSocket class methodsFor: '*monticello-override' stamp: 'st 9/27/2004 15:47'! httpGetDocument: url args: args accept: mimeType request: requestString "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. An extra requestString may be submitted and must end with crlf. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." | serverName serverAddr port sock header length bare page list firstData aStream index connectToHost connectToPort type newUrl | Socket initializeNetwork. bare := (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. bare := bare copyUpTo: $#. "remove fragment, if specified" serverName := bare copyUpTo: $/. page := bare copyFrom: serverName size + 1 to: bare size. (serverName includes: $:) ifTrue: [index := serverName indexOf: $:. port := (serverName copyFrom: index + 1 to: serverName size) asNumber. serverName := serverName copyFrom: 1 to: index - 1] ifFalse: [port := self defaultPort]. page size = 0 ifTrue: [page := '/']. "add arguments" args ifNotNil: [page := page , (self argString: args)]. (self shouldUseProxy: serverName) ifTrue: [page := 'http://' , serverName , ':' , port printString , page. "put back together" connectToHost := HTTPProxyServer. connectToPort := HTTPProxyPort] ifFalse: [connectToHost := serverName. connectToPort := port]. serverAddr := NetNameResolver addressForName: connectToHost timeout: 20. serverAddr ifNil: [^'Could not resolve the server named: ' , connectToHost]. 3 timesRepeat: [sock := HTTPSocket new. sock connectTo: serverAddr port: connectToPort. (sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [Socket deadServer: connectToHost. sock destroy. ^'Server ' , connectToHost , ' is not responding']. "Transcript cr;show: url; cr. Transcript show: page; cr." sock sendCommand: 'GET ' , page , ' HTTP/1.0' , CrLf , (mimeType ifNil: [''] ifNotNil: ['ACCEPT: ' , mimeType , CrLf]) , 'ACCEPT: text/html' , CrLf , HTTPBlabEmail , requestString , self userAgentString , CrLf , 'Host: ' , serverName , ':' , port printString , CrLf. "Always accept plain text" "may be empty" "extra user request. Authorization" "blank line automatically added" list := sock getResponseUpTo: CrLf , CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header := list at: 1. "Transcript show: page; cr; show: header; cr." firstData := list at: 3. header isEmpty ifTrue: [aStream := 'server aborted early'] ifFalse: ["dig out some headers" sock header: header. length := sock getHeader: 'content-length'. length ifNotNil: [length := length asNumber]. type := sock getHeader: 'content-type'. sock responseCode first = $3 ifTrue: [newUrl := sock getHeader: 'location'. newUrl ifNotNil: [Transcript show: 'redirecting to ' , newUrl; cr. sock destroy. newUrl := Url combine: url withRelative: newUrl. ^self httpGetDocument: newUrl args: args accept: mimeType request: requestString]]. aStream := sock getRestOfBuffer: firstData totalLength: length. "a 400-series error" sock responseCode first = $4 ifTrue: [^header , aStream contents]]. sock destroy. "Always OK to destroy!!" aStream class ~~ String ifTrue: [^MIMEDocument contentType: type content: aStream contents url: url]. aStream = 'server aborted early' ifTrue: [^aStream]]. { 'HTTPSocket class>>httpGetDocument:args:accept:request:'. aStream. url} inspect. ^'some other bad thing happened!!'! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:35'! isMagicHalo ^self valueOfProperty: #isMagicHalo ifAbsent:[false].! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 15:37'! isMagicHalo: aBool self setProperty: #isMagicHalo toValue: aBool. aBool ifFalse:[ "Reset everything" self stopStepping. "get rid of all" self startStepping. "only those of interest" ].! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:28'! magicAlpha ^self valueOfProperty: #magicAlpha ifAbsent:[1.0]! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:42'! magicAlpha: alpha self setProperty: #magicAlpha toValue: alpha. self changed.! ! !HaloMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 21:56'! setTarget: aMorph "Private!! Set the target without adding handles." target _ aMorph topRendererOrSelf. innerTarget _ target renderedMorph. innerTarget wantsDirectionHandles ifTrue: [self showDirectionHandles: true addHandles: false]. target hasHalo: true. ! ! !HaloMorph methodsFor: 'copying' stamp: 'st 9/14/2004 13:03'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "target _ target. Weakly copied" "innerTarget _ innerTarget. Weakly copied" positionOffset _ positionOffset veryDeepCopyWith: deepCopier. angleOffset _ angleOffset veryDeepCopyWith: deepCopier. growingOrRotating _ growingOrRotating veryDeepCopyWith: deepCopier. directionArrowAnchor _ directionArrowAnchor. simpleMode _ simpleMode. haloBox _ haloBox. originalExtent _ originalExtent ! ! !HaloMorph methodsFor: 'drawing' stamp: 'nk 6/13/2003 13:27'! drawOn: aCanvas "Draw this morph only if it has no target." target isNil ifTrue: [^super drawOn: aCanvas]. Preferences showBoundsInHalo ifTrue: [aCanvas frameAndFillRectangle: self bounds fillColor: Color transparent borderWidth: 1 borderColor: Color blue]! ! !HaloMorph methodsFor: 'drawing' stamp: 'ar 8/8/2001 15:13'! drawSubmorphsOn: aCanvas | alpha | ((alpha _ self magicAlpha) = 1.0) ifTrue:[^super drawSubmorphsOn: aCanvas]. ^super drawSubmorphsOn: (aCanvas asAlphaBlendingCanvas: alpha)! ! !HaloMorph methodsFor: 'dropping/grabbing' stamp: 'sw 10/2/2001 22:09'! startDrag: evt with: dragHandle "Drag my target without removing it from its owner." | itsOwner | self obtainHaloForEvent: evt andRemoveAllHandlesBut: dragHandle. positionOffset _ dragHandle center - (target point: target position in: owner). ((itsOwner _ target topRendererOrSelf owner) notNil and: [itsOwner automaticViewing]) ifTrue: [target openViewerForArgument]! ! !HaloMorph methodsFor: 'event handling' stamp: 'tk 7/14/2001 11:04'! mouseMove: evt "Drag our target around" | thePoint | thePoint _ target point: (evt position - positionOffset) from: owner. target setConstrainedPosition: thePoint hangOut: true.! ! !HaloMorph methodsFor: 'events' stamp: 'tk 7/14/2001 11:04'! dragTarget: event "Begin dragging the target" | thePoint | thePoint _ target point: event position - positionOffset from: owner. target setConstrainedPosition: thePoint hangOut: true. event hand newMouseFocus: self.! ! !HaloMorph methodsFor: 'events' stamp: 'aoy 2/17/2003 01:27'! popUpFor: aMorph event: evt "This message is sent by morphs that explicitly request the halo on a button click. Note: anEvent is in aMorphs coordinate frame." | hand anEvent | self flag: #workAround. "We should really have some event/hand here..." anEvent := evt isNil ifTrue: [hand := aMorph world activeHand. hand ifNil: [hand := aMorph world primaryHand]. hand lastEvent transformedBy: (aMorph transformedFrom: nil)] ifFalse: [hand := evt hand. evt]. self target: aMorph. hand halo: self. hand world addMorphFront: self. positionOffset := anEvent position - (aMorph point: aMorph position in: owner). self startStepping. (Preferences haloTransitions or: [self isMagicHalo]) ifTrue: [self magicAlpha: 0.0. self startSteppingSelector: #fadeInInitially]! ! !HaloMorph methodsFor: 'events' stamp: 'ar 8/8/2001 15:50'! popUpMagicallyFor: aMorph hand: aHand "Programatically pop up a halo for a given hand." Preferences magicHalos ifTrue:[ self isMagicHalo: true. self magicAlpha: 0.2]. self target: aMorph. aHand halo: self. aHand world addMorphFront: self. Preferences haloTransitions ifTrue:[ self magicAlpha: 0.0. self startSteppingSelector: #fadeInInitially. ]. positionOffset _ aHand position - (aMorph point: aMorph position in: owner). self startStepping.! ! !HaloMorph methodsFor: 'events-processing' stamp: 'nk 6/26/2002 07:19'! handleListenEvent: anEvent "We listen for possible drop events here to add back those handles after a dup/grab operation" (anEvent isMouse and:[anEvent isMove not]) ifFalse:[^ self]. "not interested" anEvent hand removeMouseListener: self. "done listening" (self world ifNil: [target world]) ifNil: [^ self]. self addHandles "and get those handles back"! ! !HaloMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 13:46'! containsPoint: aPoint "This method is overridden so that, once up, the handles will stay up as long as the mouse is within the box that encloses all the handles even if it is not over any handle or over its owner." target isNil ifTrue: [^super containsPoint: aPoint] ifFalse: [^false]! ! !HaloMorph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:34'! addSimpleHandlesTo: aHaloMorph box: aBox | aHandle | simpleMode _ true. target isWorldMorph ifTrue: [^ self addSimpleHandlesForWorldHalos]. self removeAllMorphs. "remove old handles, if any" self bounds: target renderedMorph worldBoundsForHalo. "update my size" self addHandleAt: (((aBox topLeft + aBox leftCenter) // 2) + self simpleFudgeOffset) color: Color paleBuff icon: 'Halo-MoreHandles' on: #mouseDown send: #addFullHandles to: self. aHandle _ self addGraphicalHandle: #Rotate at: aBox bottomLeft on: #mouseDown send: #startRot:with: to: self. aHandle on: #mouseMove send: #doRot:with: to: self. target isFlexMorph ifTrue: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startScale:with: to: self) on: #mouseMove send: #doScale:with: to: self] ifFalse: [(self addGraphicalHandle: #Scale at: aBox bottomRight on: #mouseDown send: #startGrow:with: to: self) on: #mouseMove send: #doGrow:with: to: self]. innerTarget wantsSimpleSketchMorphHandles ifTrue: [self addSimpleSketchMorphHandlesInBox: aBox]. growingOrRotating _ false. self layoutChanged. self changed. ! ! !HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'! addChooseGraphicHandle: haloSpec "If the target is a sketch morph, and if the governing preference is set, add a halo handle allowing the user to select a new graphic" (Preferences showChooseGraphicHaloHandle and: [innerTarget isSketchMorph]) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseNewGraphicFromHalo to: innerTarget] ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 12/13/2001 14:07'! addCollapseHandle: handleSpec "Add the collapse handle, with all of its event handlers set up, unless the target's owner is not the world or the hand." | collapseHandle | (target owner notNil "nil happens, amazingly" and: [target owner isWorldOrHandMorph]) ifFalse: [^ self]. collapseHandle _ self addHandle: handleSpec on: #mouseDown send: #mouseDownInCollapseHandle:with: to: self. collapseHandle on: #mouseUp send: #maybeCollapse:with: to: self. collapseHandle on: #mouseMove send: #setDismissColor:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 11/27/2001 11:18'! addDismissHandle: handleSpec "Add the dismiss handle according to the spec, unless selectiveHalos is on and my target resists dismissal" | dismissHandle | (target okayToAddDismissHandle or: [Preferences selectiveHalos not]) ifTrue: [dismissHandle _ self addHandle: handleSpec on: #mouseDown send: #mouseDownInDimissHandle:with: to: self. dismissHandle on: #mouseUp send: #maybeDismiss:with: to: self. dismissHandle on: #mouseDown send: #setDismissColor:with: to: self. dismissHandle on: #mouseMove send: #setDismissColor:with: to: self] ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 12/29/2004 22:18'! addDupHandle: haloSpec "Add the halo that offers duplication, or, when shift is down, make-sibling" self addHandle: haloSpec on: #mouseDown send: #doDupOrMakeSibling:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontEmphHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseEmphasisOrAlignment to: innerTarget]! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontSizeHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseFont to: innerTarget]! ! !HaloMorph methodsFor: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontStyleHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseStyle to: innerTarget]! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 12/29/2004 22:18'! addMakeSiblingHandle: haloSpec "Add the halo handle that allows a sibling instance to be torn off, or, if the shift key is down, for a deep-copy duplicate to be made." self addHandle: haloSpec on: #mouseDown send: #doMakeSiblingOrDup:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'ar 11/16/2002 19:24'! addPoohHandle: handleSpec (innerTarget isKindOf: (Smalltalk at: #WonderlandCameraMorph ifAbsent:[nil])) ifTrue: [self addHandle: handleSpec on: #mouseDown send: #strokeMode to: innerTarget] ! ! !HaloMorph methodsFor: 'handles' stamp: 'RAA 3/15/2001 11:24'! addRecolorHandle: haloSpec "Add a recolor handle to the receiver, if appropriate" | recolorHandle | "since this halo now opens a more general properties panel, allow it in all cases" "innerTarget canSetColor ifTrue:" recolorHandle _ self addHandle: haloSpec on: #mouseUp send: #doRecolor:with: to: self. recolorHandle on: #mouseUp send: #doRecolor:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'nk 6/12/2004 09:24'! addRepaintHandle: haloSpec (innerTarget isSketchMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #editDrawing to: innerTarget] ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:17'! addTileHandle: haloSpec "Add the 'tear-off-tile' handle from the spec" self addHandle: haloSpec on: #mouseDown send: #tearOffTileForTarget:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:17'! addViewHandle: haloSpec "Add the 'open viewer' handle from the halo spec" self addHandle: haloSpec on: #mouseDown send: #openViewerForTarget:with: to: self ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:18'! openViewerForTarget: evt with: aHandle "Open a viewer for my inner target" self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. innerTarget openViewerForArgument! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 10/2/2001 22:19'! tearOffTileForTarget: evt with: aHandle "Tear off a tile representing my inner target" self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. innerTarget tearOffTile! ! !HaloMorph methodsFor: 'initialization' stamp: 'sw 10/2/2001 21:20'! acceptNameEdit "If the name is currently under edit, accept the changes" | label | (label _ self findA: NameStringInHalo) ifNotNil: [label hasFocus ifTrue: [label lostFocusWithoutAccepting]]! ! !HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.6 g: 0.8 b: 1.0! ! !HaloMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:29'! initialize "initialize the state of the receiver" super initialize. "" growingOrRotating _ false. simpleMode _ Preferences simpleHalosInForce ! ! !HaloMorph methodsFor: 'meta-actions' stamp: 'jcg 9/21/2001 13:18'! blueButtonDown: event "Transfer the halo to the next likely recipient" target ifNil:[^self delete]. event hand obtainHalo: self. positionOffset _ event position - (target point: target position in: owner). self isMagicHalo ifTrue:[ self isMagicHalo: false. ^self magicAlpha: 1.0]. "wait for drags or transfer" event hand waitForClicksOrDrag: self event: event selectors: { #transferHalo:. nil. nil. #dragTarget:. } threshold: 5.! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:56'! fadeIn self magicAlpha >= 1.0 ifTrue:[self stopSteppingSelector: #fadeIn]. self magicAlpha: ((self magicAlpha + 0.1) min: 1.0) ! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:44'! fadeInInitially | max | max _ self isMagicHalo ifTrue:[0.3] ifFalse:[1.0]. self magicAlpha >= max ifTrue:[self stopSteppingSelector: #fadeInInitially]. self magicAlpha: ((self magicAlpha + (max * 0.1)) min: max) ! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 14:57'! fadeOut self magicAlpha <= 0.3 ifTrue:[self stopSteppingSelector: #fadeOut]. self magicAlpha: ((self magicAlpha - 0.1) max: 0.3) ! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:46'! fadeOutFinally self magicAlpha <= 0.05 ifTrue:[^super delete]. self magicAlpha <= 0.3 ifTrue:[ ^self magicAlpha: (self magicAlpha - 0.03 max: 0.0)]. self magicAlpha: ((self magicAlpha * 0.5) max: 0.0) ! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'! handleEntered self isMagicHalo ifFalse:[^self]. self stopStepping; startStepping. self startSteppingSelector: #fadeIn. ! ! !HaloMorph methodsFor: 'stepping' stamp: 'ar 8/8/2001 15:38'! handleLeft self isMagicHalo ifFalse:[^self]. self stopStepping; startStepping. self startSteppingSelector: #fadeOut.! ! !HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:28'! localHaloBoundsFor: aMorph "aMorph may be in the hand and perhaps not in our world" | r | r _ aMorph worldBoundsForHalo truncated. aMorph world = self world ifFalse: [^r]. ^((self transformFromOutermostWorld) globalBoundsToLocal: r) truncated! ! !HaloMorph methodsFor: 'stepping' stamp: 'nk 6/27/2003 12:32'! step | newBounds | target ifNil: [^ self]. newBounds _ target isWorldMorph ifTrue: [target bounds] ifFalse: [self localHaloBoundsFor: target renderedMorph]. newBounds = self bounds ifTrue: [^ self]. newBounds extent = self bounds extent ifTrue: [^ self position: newBounds origin]. growingOrRotating ifFalse: [submorphs size > 1 ifTrue: [self addHandles]]. "adjust halo bounds if appropriate" self bounds: newBounds! ! !HaloMorph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/2/2001 21:23'! delete "Delete the halo. Tell the target that it no longer has the halo; accept any pending edits to the name; and then either actually delete myself or start to fade out" target ifNotNil: [target hasHalo: false]. self acceptNameEdit. self isMagicHalo: false. Preferences haloTransitions ifTrue: [self stopStepping; startStepping. self startSteppingSelector: #fadeOutFinally] ifFalse: [super delete]! ! !HaloMorph methodsFor: 'updating' stamp: 'di 11/17/2001 10:56'! changed "Quicker to invalidate handles individually if target is large (especially the world)" self extent > (200@200) ifTrue: [(target notNil and: [target ~~ self world]) ifTrue: ["Invalidate 4 outer strips first, thus subsuming separate damage." (self fullBounds areasOutside: target bounds) do: [:r | self invalidRect: r]]. self submorphsDo: [:m | m changed]] ifFalse: [super changed]. ! ! !HaloMorph methodsFor: 'private' stamp: 'yo 2/12/2005 19:24'! addDirectionHandles | centerHandle d w directionShaft patch patchColor crossHairColor | self showingDirectionHandles ifFalse: [^ self]. directionArrowAnchor _ (target point: target referencePosition in: self world) rounded. patch _ target imageFormForRectangle: (Rectangle center: directionArrowAnchor extent: 3@3). patchColor _ patch colorAt: 1@1. (directionShaft _ LineMorph newSticky makeForwardArrow) borderWidth: 2; borderColor: (Color green orColorUnlike: patchColor). self positionDirectionShaft: directionShaft. self addMorphFront: directionShaft. directionShaft setCenteredBalloonText: 'Set forward direction' translated; on: #mouseDown send: #doDirection:with: to: self; on: #mouseMove send: #trackDirectionArrow:with: to: self; on: #mouseUp send: #setDirection:with: to: self. d _ 15. "diameter" w _ 3. "borderWidth" crossHairColor _ Color red orColorUnlike: patchColor. (centerHandle _ EllipseMorph newBounds: (0@0 extent: d@d) color: Color transparent) borderWidth: w; borderColor: (Color blue orColorUnlike: patchColor); addMorph: (LineMorph from: (d//2)@w to: (d//2)@(d-w-1) color: crossHairColor width: 1) lock; addMorph: (LineMorph from: w@(d//2) to: (d-w-1)@(d//2) color: crossHairColor width: 1) lock; align: centerHandle bounds center with: directionArrowAnchor. self addMorph: centerHandle. centerHandle setCenteredBalloonText: 'Set rotation center' translated; on: #mouseDown send: #prepareToTrackCenterOfRotation:with: to: self; on: #mouseMove send: #trackCenterOfRotation:with: to: self; on: #mouseUp send: #setCenterOfRotation:with: to: self ! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 8/28/2003 15:15'! addGraphicalHandle: formKey at: aPoint on: eventName send: selector to: recipient "Add the supplied form as a graphical handle centered at the given point, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle | handle _ self addGraphicalHandleFrom: formKey at: aPoint. handle on: eventName send: selector to: recipient. handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. ^ handle ! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 5/17/2004 19:53'! addHandle: handleSpec on: eventName send: selector to: recipient "Add a handle within the halo box as per the haloSpec, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle aPoint iconName colorToUse | aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement. handle _ EllipseMorph newBounds: (Rectangle center: aPoint extent: self handleSize asPoint) color: (colorToUse _ Color colorFrom: handleSpec color). handle borderColor: colorToUse muchDarker. self addMorph: handle. (iconName _ handleSpec iconSymbol) ifNotNil: [ | form | form _ ScriptingSystem formAtKey: iconName. form ifNotNil: [handle addMorphCentered: (ImageMorph new image: form; color: colorToUse makeForegroundColor; lock)]]. handle on: #mouseUp send: #endInteraction to: self. handle on: eventName send: selector to: recipient. self isMagicHalo ifTrue:[ handle on: #mouseEnter send: #handleEntered to: self. handle on: #mouseLeave send: #handleLeft to: self]. handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. ^ handle ! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 5/17/2004 19:48'! addHandleAt: aPoint color: aColor icon: iconName on: eventName send: selector to: recipient "Add a handle centered at the given point with the given color, and set it up to respond to the given event by sending the given selector to the given recipient. Return the handle." | handle | handle _ EllipseMorph newBounds: (Rectangle center: aPoint extent: self handleSize asPoint) color: aColor. handle borderColor: aColor muchDarker. self addMorph: handle. iconName ifNotNil: [ | form | form _ ScriptingSystem formAtKey: iconName. form ifNotNil: [handle addMorphCentered: (ImageMorph new image: form; color: aColor makeForegroundColor; lock)]]. handle on: #mouseUp send: #endInteraction to: self. handle on: eventName send: selector to: recipient. handle setBalloonText: (target balloonHelpTextForHandle: handle) translated. ^ handle ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 9/20/2004 15:19'! addNameBeneath: outerRectangle string: aString "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." | nameMorph namePosition w | w _ self world ifNil:[target world]. nameMorph _ NameStringInHalo contents: aString font: Preferences standardHaloLabelFont. nameMorph color: Color black. nameMorph useStringFormat; target: innerTarget; putSelector: #tryToRenameTo:. namePosition _ outerRectangle bottomCenter - ((nameMorph width // 2) @ (self handleSize negated // 2 - 1)). nameMorph position: (namePosition min: w viewBox bottomRight - nameMorph extent y + 2). nameMorph balloonTextSelector: #objectNameInHalo. self addMorph: nameMorph. ^ nameMorph! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/27/2002 09:27'! doDebug: evt with: menuHandle "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" | menu | self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. self world displayWorld. evt shiftPressed ifTrue: [self delete. ^ innerTarget inspectInMorphic: evt]. menu _ innerTarget buildDebugMenu: evt hand. menu addTitle: (innerTarget externalName truncateWithElipsisTo: 40). menu popUpEvent: evt in: self world! ! !HaloMorph methodsFor: 'private' stamp: 'tk 7/14/2001 11:04'! doDrag: evt with: dragHandle | thePoint | evt hand obtainHalo: self. thePoint _ target point: evt position - positionOffset from: owner. target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true. ! ! !HaloMorph methodsFor: 'private' stamp: 'jcg 5/30/2002 09:12'! doDup: evt with: dupHandle "Ask hand to duplicate my target." (target isKindOf: SelectionMorph) ifTrue: [^ target doDup: evt fromHalo: self handle: dupHandle]. self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle. self setTarget: (target duplicateMorph: evt). evt hand grabMorph: target. self step. "update position if necessary" evt hand addMouseListener: self. "Listen for the drop"! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:35'! doGrab: evt with: grabHandle "Ask hand to grab my target." self obtainHaloForEvent: evt andRemoveAllHandlesBut: grabHandle. evt hand grabMorph: target. self step. "update position if necessary" evt hand addMouseListener: self. "Listen for the drop"! ! !HaloMorph methodsFor: 'private' stamp: 'st 9/14/2004 12:54'! doGrow: evt with: growHandle "Called while the mouse is down in the grow handle" | newExtent extentToUse scale | evt hand obtainHalo: self. newExtent _ (target pointFromWorld: (target griddedPoint: evt cursorPoint - positionOffset)) - target topLeft. evt shiftPressed ifTrue: [ scale _ (newExtent x / (originalExtent x max: 1)) min: (newExtent y / (originalExtent y max: 1)). newExtent _ (originalExtent x * scale) asInteger @ (originalExtent y * scale) asInteger ]. (newExtent x < 1 or: [newExtent y < 1 ]) ifTrue: [^ self]. target renderedMorph setExtentFromHalo: (extentToUse _ newExtent). growHandle position: evt cursorPoint - (growHandle extent // 2). self layoutChanged. (self valueOfProperty: #commandInProgress) ifNotNilDo: [:cmd | "Update the final extent" cmd redoTarget: target selector: #setExtentFromHalo: argument: extentToUse] ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 7/28/2004 15:58'! doMakeSibling: evt with: dupHandle "Ask hand to make a sibling of my target. Only reachable if target is of a uniclass" target assuredPlayer assureUniClass. self obtainHaloForEvent: evt andRemoveAllHandlesBut: dupHandle. self setTarget: (target makeSiblings: 1) first. evt hand grabMorph: target. self step. "update position if necessary" evt hand addMouseListener: self. "Listen for the drop"! ! !HaloMorph methodsFor: 'private' stamp: 'ar 11/29/2001 20:01'! doMenu: evt with: menuHandle "Ask hand to invoke the halo menu for my inner target." | menu | self obtainHaloForEvent: evt andRemoveAllHandlesBut: nil. self world displayWorld. menu _ innerTarget buildHandleMenu: evt hand. innerTarget addTitleForHaloMenu: menu. menu popUpEvent: evt in: self world. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 9/20/2001 00:16'! doRecolor: evt with: aHandle "The mouse went down in the 'recolor' halo handle. Allow the user to change the color of the innerTarget" evt hand obtainHalo: self. (aHandle containsPoint: evt cursorPoint) ifFalse: "only do it if mouse still in handle on mouse up" [self delete. target addHalo: evt] ifTrue: [(Preferences propertySheetFromHalo == evt shiftPressed) ifFalse: [innerTarget openAPropertySheet] ifTrue: [innerTarget changeColor]. self showingDirectionHandles ifTrue: [self addHandles]]! ! !HaloMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:21'! doRot: evt with: rotHandle "Update the rotation of my target if it is rotatable. Keep the relevant command object up to date." | degrees | evt hand obtainHalo: self. degrees _ (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees. degrees _ degrees - angleOffset degrees. degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. degrees = 0.0 ifTrue: [rotHandle color: Color lightBlue] ifFalse: [rotHandle color: Color blue]. rotHandle submorphsDo: [:m | m color: rotHandle color makeForegroundColor]. self removeAllHandlesBut: rotHandle. self showingDirectionHandles ifFalse: [self showDirectionHandles: true addHandles: false]. self addDirectionHandles. target rotationDegrees: degrees. rotHandle position: evt cursorPoint - (rotHandle extent // 2). (self valueOfProperty: #commandInProgress) ifNotNilDo: [:cmd | "Update the final rotation" cmd redoTarget: target selector: #rotationDegrees: argument: degrees]. self layoutChanged! ! !HaloMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:21'! endInteraction "Clean up after a user interaction with the a halo control" | m | self isMagicHalo: false. "no longer" self magicAlpha: 1.0. (target isInWorld not or: [owner isNil]) ifTrue: [^self]. [target isFlexMorph and: [target hasNoScaleOrRotation]] whileTrue: [m := target firstSubmorph. target removeFlexShell. target := m]. self isInWorld ifTrue: ["make sure handles show in front, even if flex shell added" self comeToFront. self addHandles]. (self valueOfProperty: #commandInProgress) ifNotNilDo: [:cmd | self rememberCommand: cmd. self removeProperty: #commandInProgress]! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 5/17/2004 20:18'! handleSize ^ Preferences biggerHandles ifTrue: [20] ifFalse: [16]! ! !HaloMorph methodsFor: 'private' stamp: 'aoy 2/15/2003 21:10'! maybeCollapse: evt with: collapseHandle "Ask hand to collapse my target if mouse comes up in it." evt hand obtainHalo: self. self delete. (collapseHandle containsPoint: evt cursorPoint) ifFalse: [ target addHalo: evt] ifTrue: [ target collapse]! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 9/5/2003 18:32'! maybeDismiss: evt with: dismissHandle "Ask hand to dismiss my target if mouse comes up in it." evt hand obtainHalo: self. (dismissHandle containsPoint: evt cursorPoint) ifFalse: [self delete. target addHalo: evt] ifTrue: [target resistsRemoval ifTrue: [(PopUpMenu confirm: 'Really throw this away' translated trueChoice: 'Yes' translated falseChoice: 'Um, no, let me reconsider' translated) ifFalse: [^ self]]. Preferences preserveTrash ifTrue: [Preferences soundsEnabled ifTrue: [TrashCanMorph playDeleteSound]. self stopStepping. super delete. target slideToTrash: evt] ifFalse: [self delete. target dismissViaHalo]]! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/3/2001 00:21'! mouseDownInCollapseHandle: evt with: collapseHandle "The mouse went down in the collapse handle; collapse the morph" self obtainHaloForEvent: evt andRemoveAllHandlesBut: collapseHandle. self setDismissColor: evt with: collapseHandle! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/2/2001 22:16'! obtainHaloForEvent: evt andRemoveAllHandlesBut: aHandle "Make sure the event's hand correlates with the receiver, and remove all handles except the given one. If nil is provided as the handles argument, the result is that all handles are removed. Note that any pending edits to the name-string in the halo are accepted at this time." evt hand obtainHalo: self. self acceptNameEdit. self removeAllHandlesBut: aHandle! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:35'! prepareToTrackCenterOfRotation: evt with: rotationHandle evt hand obtainHalo: self. evt shiftPressed ifTrue:[ self removeAllHandlesBut: rotationHandle. ] ifFalse:[ rotationHandle setProperty: #dragByCenterOfRotation toValue: true. self startDrag: evt with: rotationHandle ]. evt hand showTemporaryCursor: Cursor blank! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:33'! setCenterOfRotation: evt with: rotationHandle | localPt | evt hand obtainHalo: self. evt hand showTemporaryCursor: nil. (rotationHandle hasProperty: #dragByCenterOfRotation) ifFalse:[ localPt _ innerTarget transformFromWorld globalPointToLocal: rotationHandle center. innerTarget setRotationCenterFrom: localPt. ]. rotationHandle removeProperty: #dragByCenterOfRotation. self endInteraction ! ! !HaloMorph methodsFor: 'private' stamp: 'ar 6/12/2001 05:24'! setDirection: anEvent with: directionHandle "The user has let up after having dragged the direction arrow; now set the forward direction of the actual SketchMorph accordingly" anEvent hand obtainHalo: self. target setDirectionFrom: directionHandle center. self endInteraction! ! !HaloMorph methodsFor: 'private' stamp: 'aoy 2/17/2003 01:27'! showDirectionHandles: wantToShow addHandles: needHandles directionArrowAnchor := wantToShow ifTrue: [target referencePositionInWorld "not nil means show"] ifFalse: [nil]. needHandles ifTrue: [self addHandles] ! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 19:04'! showingDirectionHandles ^directionArrowAnchor notNil! ! !HaloMorph methodsFor: 'private' stamp: 'st 9/14/2004 12:51'! startGrow: evt with: growHandle "Initialize resizing of my target. Launch a command representing it, to support Undo" | botRt | self obtainHaloForEvent: evt andRemoveAllHandlesBut: growHandle. botRt _ target point: target bottomRight in: owner. positionOffset _ (self world viewBox containsPoint: botRt) ifTrue: [evt cursorPoint - botRt] ifFalse: [0@0]. self setProperty: #commandInProgress toValue: (Command new cmdWording: 'resizing' translated; undoTarget: target selector: #setExtentFromHalo: argument: target extent). originalExtent _ target extent! ! !HaloMorph methodsFor: 'private' stamp: 'dgd 8/26/2003 21:44'! startRot: evt with: rotHandle "Initialize rotation of my target if it is rotatable. Launch a command object to represent the action" self obtainHaloForEvent: evt andRemoveAllHandlesBut: rotHandle. target isFlexMorph ifFalse: [target isInWorld ifFalse: [self setTarget: target player costume]. target addFlexShellIfNecessary]. growingOrRotating _ true. self removeAllHandlesBut: rotHandle. "remove all other handles" angleOffset _ evt cursorPoint - (target pointInWorld: target referencePosition). angleOffset _ Point r: angleOffset r degrees: angleOffset degrees - target rotationDegrees. self setProperty: #commandInProgress toValue: (Command new cmdWording: 'rotating' translated; undoTarget: target selector: #rotationDegrees: argument: target rotationDegrees) ! ! !HaloMorph methodsFor: 'private' stamp: 'di 11/28/2001 18:25'! startScale: evt with: scaleHandle "Initialize scaling of my target." self obtainHaloForEvent: evt andRemoveAllHandlesBut: scaleHandle. target isFlexMorph ifFalse: [target addFlexShellIfNecessary]. growingOrRotating _ true. positionOffset _ 0@0 ! ! !HaloMorph methodsFor: 'private' stamp: 'ar 10/8/2001 14:32'! trackCenterOfRotation: anEvent with: rotationHandle (rotationHandle hasProperty: #dragByCenterOfRotation) ifTrue:[^self doDrag: anEvent with: rotationHandle]. anEvent hand obtainHalo: self. rotationHandle center: anEvent cursorPoint.! ! !HaloMorph methodsFor: '*connectors-private' stamp: 'sw 12/29/2004 22:59'! doDupOrMakeSibling: evt with: dupHandle "Ask hand to duplicate my target, if shift key *not* pressed, or make a sibling if shift key *is* pressed" ^ evt shiftPressed ifTrue: [dupHandle color: Color green muchDarker. self doMakeSibling: evt with: dupHandle] ifFalse: [self doDup: evt with: dupHandle]! ! !HaloMorph methodsFor: '*connectors-private' stamp: 'sw 12/29/2004 22:59'! doMakeSiblingOrDup: evt with: dupHandle "Ask hand to duplicate my target, if shift key *is* pressed, or make a sibling if shift key *not* pressed" ^ evt shiftPressed ifFalse: [self doMakeSibling: evt with: dupHandle] ifTrue: [dupHandle color: Color green. self doDup: evt with: dupHandle]! ! !HaloSpec methodsFor: 'printing' stamp: 'sw 11/15/2001 16:31'! printOn: aStream "Add a textual printout representing the receiver to a stream" super printOn: aStream. aStream nextPutAll: ' (', addHandleSelector asString, ' ', iconSymbol asString, ')'! ! !HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0! Sets spec's for how handles are layed out in a halo.! !HaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 23:12'! haloThemeRadioButtons "Answer a column of butons representing the choices of halo theme" | buttonColumn aRow aRadioButton aStringMorph | buttonColumn := AlignmentMorph newColumn beTransparent. #( (iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') (classicHaloSpecs classic classicHalosInForce 'plain circular halos') (simpleFullHaloSpecifications simple simpleHalosInForce 'fewer, larger halos') (customHaloSpecs custom customHalosInForce 'customizable halos')) do: [:quad | aRow := AlignmentMorph newRow beTransparent. aRow addMorph: (aRadioButton := UpdatingThreePhaseButtonMorph radioButton). aRadioButton target: Preferences. aRadioButton setBalloonText: quad fourth. aRadioButton actionSelector: #installHaloTheme:. aRadioButton getSelector: quad third. aRadioButton arguments: (Array with: quad first). aRow addTransparentSpacerOfSize: (4 @ 0). aRow addMorphBack: (aStringMorph := StringMorph contents: quad second asString). aStringMorph setBalloonText: quad fourth. buttonColumn addMorphBack: aRow]. ^ buttonColumn "(Preferences preferenceAt: #haloTheme) view tearOffButton"! ! !HaloThemePreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 23:11'! representativeButtonWithColor: aColor inPanel: aPreferencesPanel | outerButton editButton | editButton := SimpleButtonMorph new target: Preferences; color: Color transparent; actionSelector: #editCustomHalos; label: 'Edit custom halos' translated; setBalloonText: 'Click here to edit the method that defines the custom halos' translated. outerButton := AlignmentMorph newColumn. outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]); hResizing: (aPreferencesPanel ifNil: [#shrinkWrap] ifNotNil: [#spaceFill]); vResizing: #shrinkWrap; addTransparentSpacerOfSize: (0@4); addMorphBack: self haloThemeRadioButtons; addTransparentSpacerOfSize: (0@4); addMorphBack: editButton. ^outerButton. "(Preferences preferenceAt: #haloTheme) view tearOffButton" ! ! !HaloThemePreferenceView commentStamp: '<historical>' prior: 0! I am responsible for building the view for the preference that choose the halo theme! !HaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:58'! initialize "adding the halo theme preference to Preferences and registering myself as its view" PreferenceViewRegistry ofHaloThemePreferences register: self. Preferences addPreference: #haloTheme categories: {#halos} default: #iconicHaloSpecifications balloonHelp: '' projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofHaloThemePreferences.! ! !HaloThemePreferenceView class methodsFor: 'class initialization' stamp: 'hpt 9/26/2004 15:58'! unload PreferenceViewRegistry ofHaloThemePreferences unregister: self.! ! !HaloThemePreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:10'! handlesPanel: aPreferencePanel ^aPreferencePanel isKindOf: PreferencesPanel! ! !Halt methodsFor: 'priv handling' stamp: 'ajh 8/5/2003 11:30'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! anyButtonPressed ^lastMouseEvent anyButtonPressed! ! !HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed not! ! !HandMorph methodsFor: 'balloon help' stamp: 'sw 10/15/2002 20:01'! deleteBalloonTarget: aMorph "Delete any existing balloon help. This is now done unconditionally, whether or not the morph supplied is the same as the current balloon target" self balloonHelp: nil " | h | h _ self balloonHelp ifNil: [^ self]. h balloonOwner == aMorph ifTrue: [self balloonHelp: nil]"! ! !HandMorph methodsFor: 'change reporting' stamp: 'ar 12/30/2001 17:32'! invalidRect: damageRect from: aMorph "Note that a change has occurred and record the given damage rectangle relative to the origin this hand's cache." hasChanged _ true. aMorph == self ifTrue:[^self]. damageRecorder recordInvalidRect: damageRect. ! ! !HandMorph methodsFor: 'cursor' stamp: 'dgd 2/21/2003 22:49'! showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal hardware cursor." self changed. temporaryCursorOffset ifNotNil: [bounds := bounds translateBy: temporaryCursorOffset negated]. cursorOrNil isNil ifTrue: [temporaryCursor := temporaryCursorOffset := nil] ifFalse: [temporaryCursor := cursorOrNil asCursorForm. temporaryCursorOffset := temporaryCursor offset - hotSpotOffset]. bounds := self cursorBounds. self userInitials: userInitials andPicture: self userPicture; layoutChanged; changed! ! !HandMorph methodsFor: 'cursor' stamp: 'NS 2/17/2001 11:01'! temporaryCursor ^ temporaryCursor! ! !HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:29'! waitForClicksOrDrag: aMorph event: evt "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. The callback methods invoked on aMorph (which are passed a copy of evt) are: #click: sent when the mouse button goes up within doubleClickTime. #doubleClick: sent when the mouse goes up, down, and up again all within DoubleClickTime. #doubleClickTimeout: sent when the mouse does not have a doubleClick within DoubleClickTime. #startDrag: sent when the mouse moves more than 10 pixels from evt's position within DoubleClickTime. Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, which is typically done by aMorph in its click:, doubleClick:, or drag: methods." ^self waitForClicksOrDrag: aMorph event: evt selectors: #( #click: #doubleClick: #doubleClickTimeout: #startDrag:) threshold: 10 ! ! !HandMorph methodsFor: 'double click support' stamp: 'nk 7/26/2004 10:32'! waitForClicksOrDrag: aMorph event: evt selectors: clickAndDragSelectors threshold: threshold "Wait for mouse button and movement events, informing aMorph about events interesting to it via callbacks. This message is typically sent to the Hand by aMorph when it first receives a mouse-down event. The callback methods, named in clickAndDragSelectors and passed a copy of evt, are: 1 (click) sent when the mouse button goes up within doubleClickTime. 2 (doubleClick) sent when the mouse goes up, down, and up again all within DoubleClickTime. 3 (doubleClickTimeout) sent when the mouse does not have a doubleClick within DoubleClickTime. 4 (startDrag) sent when the mouse moves more than threshold pixels from evt's position within DoubleClickTime. Note that mouseMove: and mouseUp: events are not sent to aMorph until it becomes the mouse focus, which is typically done by aMorph in its click:, doubleClick:, or drag: methods." mouseClickState _ MouseClickState new client: aMorph click: clickAndDragSelectors first dblClick: clickAndDragSelectors second dblClickTime: DoubleClickTime dblClickTimeout: clickAndDragSelectors third drag: clickAndDragSelectors fourth threshold: threshold event: evt. ! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:43'! drawOn: aCanvas "Draw the hand itself (i.e., the cursor)." | userPic | temporaryCursor isNil ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft] ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft]. self hasUserInformation ifTrue: [aCanvas drawString: userInitials at: self cursorBounds topRight + (0 @ 4) font: nil color: color. (userPic := self userPicture) ifNotNil: [aCanvas paintImage: userPic at: self cursorBounds topRight + (0 @ 24)]]! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:44'! fullDrawOn: aCanvas "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version caches an image of the morphs being held by the hand for better performance. This cache is invalidated if one of those morphs changes." | disableCaching subBnds roundCorners rounded | self visible ifFalse: [^self]. (aCanvas isVisible: self fullBounds) ifFalse: [^self]. disableCaching := false. disableCaching ifTrue: [self nonCachingFullDrawOn: aCanvas. ^self]. submorphs isEmpty ifTrue: [cacheCanvas := nil. ^self drawOn: aCanvas]. "just draw the hand itself" subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). self updateCacheCanvas: aCanvas. (cacheCanvas isNil or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) ifTrue: ["could not use caching due to translucency; do full draw" self nonCachingFullDrawOn: aCanvas. ^self]. "--> begin rounded corners hack <---" roundCorners := cachedCanvasHasHoles == false and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]. roundCorners ifTrue: [rounded := submorphs first. aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during: [:shadowCanvas | shadowCanvas roundCornersOf: rounded during: [(subBnds areasOutside: (rounded boundsWithinCorners translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. aCanvas roundCornersOf: rounded during: [aCanvas drawImage: cacheCanvas form at: subBnds origin sourceRect: cacheCanvas form boundingBox]. ^self drawOn: aCanvas "draw the hand itself in front of morphs"]. "--> end rounded corners hack <---" "draw the shadow" aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during: [:shadowCanvas | cachedCanvasHasHoles ifTrue: ["Have to draw the real shadow of the form" shadowCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: ["Much faster if only have to shade the edge of a solid rectangle" (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. "draw morphs in front of the shadow using the cached Form" cachedCanvasHasHoles ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: [aCanvas drawImage: cacheCanvas form at: subBnds origin sourceRect: cacheCanvas form boundingBox]. self drawOn: aCanvas "draw the hand itself in front of morphs"! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:46'! hasUserInformation ^self userInitials notEmpty or: [self userPicture notNil]! ! !HandMorph methodsFor: 'drawing' stamp: 'nk 5/6/2003 20:55'! needsToBeDrawn "Return true if this hand must be drawn explicitely instead of being drawn via the hardware cursor. This is the case if it (a) it is a remote hand, (b) it is showing a temporary cursor, or (c) it is not empty and there are any visible submorphs. If using the software cursor, ensure that the hardware cursor is hidden." "Details: Return true if this hand has a saved patch to ensure that is is processed by the world. This saved patch will be deleted after one final display pass when it becomes possible to start using the hardware cursor again. This trick gives us one last display cycle to allow us to remove the software cursor and shadow from the display." (savedPatch notNil or: [ (submorphs anySatisfy: [ :ea | ea visible ]) or: [ temporaryCursor notNil or: [ self hasUserInformation ]]]) ifTrue: [ "using the software cursor; hide the hardware one" Sensor currentCursor == Cursor blank ifFalse: [Cursor blank show]. ^ true]. ^ false ! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! restoreSavedPatchOn: aCanvas "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." hasChanged := false. savedPatch ifNotNil: [aCanvas drawImage: savedPatch at: savedPatch offset. self hasUserInformation ifTrue: [^self]. "cannot use hw cursor if so" submorphs notEmpty ifTrue: [^self]. temporaryCursor ifNotNil: [^self]. "Make the transition to using hardware cursor. Clear savedPatch and report one final damage rectangle to erase the image of the software cursor." super invalidRect: (savedPatch offset extent: savedPatch extent + self shadowOffset) from: self. Sensor currentCursor == Cursor normal ifFalse: [Cursor normal show]. "show hardware cursor" savedPatch := nil]! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! savePatchFrom: aCanvas "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." | damageRect myBnds | damageRect := myBnds := self fullBounds. savedPatch ifNotNil: [damageRect := myBnds merge: (savedPatch offset extent: savedPatch extent)]. (savedPatch isNil or: [savedPatch extent ~= myBnds extent]) ifTrue: ["allocate new patch form if needed" savedPatch := aCanvas form allocateForm: myBnds extent]. aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin) into: savedPatch. savedPatch offset: myBnds topLeft. ^damageRect! ! !HandMorph methodsFor: 'drawing' stamp: 'dgd 2/21/2003 22:49'! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." "Note: The following is an attempt to quickly get out if there's no change" | subBnds rectList nPix | subBnds := Rectangle merging: (submorphs collect: [:m | m fullBounds]). rectList := damageRecorder invalidRectsFullBounds: subBnds. damageRecorder reset. (rectList isEmpty and: [cacheCanvas notNil and: [cacheCanvas extent = subBnds extent]]) ifTrue: [^self]. "Always check for real translucency -- can't be cached in a form" self submorphsDo: [:m | m wantsToBeCachedByHand ifFalse: [cacheCanvas := nil. cachedCanvasHasHoles := true. ^self]]. (cacheCanvas isNil or: [cacheCanvas extent ~= subBnds extent]) ifTrue: [cacheCanvas := (aCanvas allocateForm: subBnds extent) getCanvas. cacheCanvas translateBy: subBnds origin negated during: [:tempCanvas | self drawSubmorphsOn: tempCanvas]. self submorphsDo: [:m | (m areasRemainingToFill: subBnds) isEmpty ifTrue: [^cachedCanvasHasHoles := false]]. nPix := cacheCanvas form tallyPixelValues first. "--> begin rounded corners hack <---" cachedCanvasHasHoles := (nPix = 48 and: [submorphs size = 1 and: [submorphs first wantsRoundedCorners]]) ifTrue: [false] ifFalse: [nPix > 0]. "--> end rounded corners hack <---" ^self]. "incrementally update the cache canvas" cacheCanvas translateBy: subBnds origin negated during: [:cc | rectList do: [:r | cc clipBy: r during: [:c | c fillColor: Color transparent. self drawSubmorphsOn: c]]]! ! !HandMorph methodsFor: 'event handling' stamp: 'tpr 1/5/2005 17:34'! checkForMoreKeyboard "Quick check for more keyboard activity -- Allows, eg, many characters to be accumulated into a single replacement during type-in." | evtBuf | self flag: #arNote. "Will not work if we don't examine event queue in Sensor" evtBuf := Sensor peekKeyboardEvent. evtBuf ifNil: [^nil]. ^self generateKeyboardEvent: evtBuf! ! !HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:43'! cursorPoint "Implemented for allowing embedded worlds in an event cycle to query a hand's position and get it in its coordinates. The same can be achieved by #point:from: but this is simply much more convenient since it will look as if the hand is in the lower world." | pos | pos := self position. (ActiveWorld isNil or: [ActiveWorld == owner]) ifTrue: [^pos]. ^ActiveWorld point: pos from: owner! ! !HandMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:48'! processEvents "Process user input events from the local input devices." | evt evtBuf type hadAny | ActiveEvent ifNotNil: ["Meaning that we were invoked from within an event response. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]. hadAny := false. [(evtBuf := Sensor nextEvent) isNil] whileFalse: [evt := nil. "for unknown event types" type := evtBuf first. type = EventTypeMouse ifTrue: [evt := self generateMouseEvent: evtBuf]. type = EventTypeKeyboard ifTrue: [evt := self generateKeyboardEvent: evtBuf]. type = EventTypeDragDropFiles ifTrue: [evt := self generateDropFilesEvent: evtBuf]. "All other events are ignored" (type ~= EventTypeDragDropFiles and: [evt isNil]) ifTrue: [^self]. evt isNil ifFalse: ["Finally, handle it" self handleEvent: evt. hadAny := true. "For better user feedback, return immediately after a mouse event has been processed." evt isMouse ifTrue: [^self]]]. "note: if we come here we didn't have any mouse events" mouseClickState notNil ifTrue: ["No mouse events during this cycle. Make sure click states time out accordingly" mouseClickState handleEvent: lastMouseEvent asMouseMove from: self]. hadAny ifFalse: ["No pending events. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]! ! !HandMorph methodsFor: 'events-processing' stamp: 'nk 7/20/2003 10:02'! handleEvent: anEvent | evt ofs | owner ifNil:[^self]. evt _ anEvent. EventStats ifNil:[EventStats _ IdentityDictionary new]. EventStats at: #count put: (EventStats at: #count ifAbsent:[0]) + 1. EventStats at: evt type put: (EventStats at: evt type ifAbsent:[0]) + 1. evt isMouseOver ifTrue:[^self sendMouseEvent: evt]. ShowEvents == true ifTrue:[ Display fill: (0@0 extent: 250@120) rule: Form over fillColor: Color white. ofs _ (owner hands indexOf: self) - 1 * 60. evt printString displayAt: (0@ofs) + (evt isKeyboard ifTrue:[0@30] ifFalse:[0@0]). self keyboardFocus printString displayAt: (0@ofs)+(0@45). ]. "Notify listeners" self sendListenEvent: evt to: self eventListeners. evt isKeyboard ifTrue:[ self sendListenEvent: evt to: self keyboardListeners. self sendKeyboardEvent: evt. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isDropEvent ifTrue:[ self sendEvent: evt focus: nil. ^self mouseOverHandler processMouseOver: lastMouseEvent]. evt isMouse ifTrue:[ self sendListenEvent: evt to: self mouseListeners. lastMouseEvent _ evt]. "Check for pending drag or double click operations." mouseClickState ifNotNil:[ (mouseClickState handleEvent: evt from: self) ifFalse:[ "Possibly dispatched #click: or something and will not re-establish otherwise" ^self mouseOverHandler processMouseOver: lastMouseEvent]]. evt isMove ifTrue:[ self position: evt position. self sendMouseEvent: evt. ] ifFalse:[ "Issue a synthetic move event if we're not at the position of the event" (evt position = self position) ifFalse:[self moveToEvent: evt]. "Drop submorphs on button events" (self hasSubmorphs) ifTrue:[self dropMorphs: evt] ifFalse:[self sendMouseEvent: evt]. ]. ShowEvents == true ifTrue:[self mouseFocus printString displayAt: (0@ofs) + (0@15)]. self mouseOverHandler processMouseOver: lastMouseEvent. ! ! !HandMorph methodsFor: 'events-processing' stamp: 'nk 2/15/2004 09:01'! isCapturingGesturePoints ^false! ! !HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:10'! compositionWindowManager ^ self class compositionWindowManager. ! ! !HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44'! mouseFocus: aMorphOrNil mouseFocus _ aMorphOrNil! ! !HandMorph methodsFor: 'focus handling' stamp: 'yo 11/7/2002 19:11'! newKeyboardFocus: aMorphOrNil "Make the given morph the new keyboard focus, canceling the previous keyboard focus if any. If the argument is nil, the current keyboard focus is cancelled." | oldFocus | oldFocus _ self keyboardFocus. self keyboardFocus: aMorphOrNil. oldFocus ifNotNil: [oldFocus == aMorphOrNil ifFalse: [oldFocus keyboardFocusChange: false]]. aMorphOrNil ifNotNil: [aMorphOrNil keyboardFocusChange: true. self compositionWindowManager keyboardFocusForAMorph: aMorphOrNil]. ! ! !HandMorph methodsFor: 'focus handling' stamp: 'dgd 2/21/2003 22:48'! newMouseFocus: aMorph event: event aMorph isNil ifFalse: [targetOffset := event cursorPoint - aMorph position]. ^self newMouseFocus: aMorph! ! !HandMorph methodsFor: 'geometry' stamp: 'ar 3/20/2001 20:34'! position ^temporaryCursor ifNil: [bounds topLeft] ifNotNil: [bounds topLeft - temporaryCursorOffset]! ! !HandMorph methodsFor: 'geometry' stamp: 'ar 12/30/2001 20:44'! userInitials: aString andPicture: aForm | cb pictRect initRect f | userInitials _ aString. pictRect _ initRect _ cb _ self cursorBounds. userInitials isEmpty ifFalse: [ f _ TextStyle defaultFont. initRect _ cb topRight + (0@4) extent: (f widthOfString: userInitials)@(f height). ]. self userPicture: aForm. aForm ifNotNil: [ pictRect _ (self cursorBounds topRight + (0@24)) extent: aForm extent. ]. self bounds: ((cb merge: initRect) merge: pictRect). ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 8/13/2003 11:39'! dropMorph: aMorph event: anEvent "Drop the given morph which was carried by the hand" | event dropped | (anEvent isMouseUp and:[aMorph shouldDropOnMouseUp not]) ifTrue:[^self]. "Note: For robustness in drag and drop handling we remove the morph BEFORE we drop him, but we keep his owner set to the hand. This prevents system lockups when there is a problem in drop handling (for example if there's an error in #wantsToBeDroppedInto:). THIS TECHNIQUE IS NOT RECOMMENDED FOR CASUAL USE." self privateRemove: aMorph. aMorph privateOwner: self. dropped _ aMorph. (dropped hasProperty: #addedFlexAtGrab) ifTrue:[dropped _ aMorph removeFlexShell]. event _ DropEvent new setPosition: self position contents: dropped hand: self. self sendEvent: event focus: nil. event wasHandled ifFalse:[aMorph rejectDropMorphEvent: event]. aMorph owner == self ifTrue:[aMorph delete]. self mouseOverHandler processMouseOver: anEvent.! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'ar 4/23/2001 15:17'! grabMorph: aMorph from: formerOwner "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." | grabbed offset targetPoint grabTransform fullTransform | self releaseMouseFocus. "Break focus" grabbed _ aMorph. aMorph keepsTransform ifTrue:[ grabTransform _ fullTransform _ IdentityTransform new. ] ifFalse:[ "Compute the transform to apply to the grabbed morph" grabTransform _ formerOwner ifNil: [IdentityTransform new] ifNotNil: [formerOwner grabTransform]. "Compute the full transform for the grabbed morph" fullTransform _ formerOwner ifNil: [IdentityTransform new] ifNotNil: [formerOwner transformFrom: owner]. ]. "targetPoint is point in aMorphs reference frame" targetPoint _ fullTransform globalPointToLocal: self position. "but current position will be determined by grabTransform, so compute offset" offset _ targetPoint - (grabTransform globalPointToLocal: self position). "apply the transform that should be used after grabbing" grabbed _ grabbed transformedBy: grabTransform. grabbed == aMorph ifFalse: [grabbed setProperty: #addedFlexAtGrab toValue: true]. "offset target to compensate for differences in transforms" grabbed position: grabbed position - offset asIntegerPoint. "And compute distance from hand's position" targetOffset _ grabbed position - self position. self addMorphBack: grabbed. grabbed justGrabbedFrom: formerOwner.! ! !HandMorph methodsFor: 'halo handling' stamp: 'RAA 2/13/2001 17:24'! removeHaloFromClick: anEvent on: aMorph | halo | halo _ self halo ifNil:[^self]. (halo target hasOwner: self) ifTrue:[^self]. (halo staysUpWhenMouseIsDownIn: aMorph) ifFalse:[ halo delete. self removeProperty: #halo. ].! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:49'! removePendingHaloFor: aMorph "Get rid of pending balloon help or halo actions." self removeAlarm: #spawnMagicHaloFor:.! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:50'! spawnMagicHaloFor: aMorph (self halo notNil and:[self halo target == aMorph]) ifTrue:[^self]. aMorph addMagicHaloFor: self.! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 8/8/2001 14:51'! triggerHaloFor: aMorph after: timeOut "Trigger automatic halo after the given time out for some morph" self addAlarm: #spawnMagicHaloFor: with: aMorph after: timeOut! ! !HandMorph methodsFor: 'initialization' stamp: 'tk 8/9/2001 16:55'! initForEvents mouseOverHandler _ nil. lastMouseEvent _ MouseEvent new setType: #mouseMove position: 0@0 buttons: 0 hand: self. lastEventBuffer _ {1. 0. 0. 0. 0. 0. nil. nil}. self resetClickState.! ! !HandMorph methodsFor: 'initialization' stamp: 'ar 10/26/2000 14:58'! initialize super initialize. self initForEvents. keyboardFocus _ nil. mouseFocus _ nil. bounds _ 0@0 extent: Cursor normal extent. userInitials _ ''. damageRecorder _ DamageRecorder new. cachedCanvasHasHoles _ false. temporaryCursor _ temporaryCursorOffset _ nil. self initForEvents.! ! !HandMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:28'! interrupted "Something went wrong - we're about to bring up a debugger. Release some stuff that could be problematic." self releaseAllFoci. "or else debugger might not handle clicks" ! ! !HandMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:27'! resourceJustLoaded "In case resource relates to me" cacheCanvas _ nil.! ! !HandMorph methodsFor: 'listeners' stamp: 'dgd 2/21/2003 22:48'! removeListener: anObject from: aListenerGroup "Remove anObject from the given listener group. Return the new group." | listeners | aListenerGroup ifNil: [^nil]. listeners := aListenerGroup. listeners := listeners copyWithout: anObject. listeners := listeners copyWithout: nil. "obsolete entries" listeners isEmpty ifTrue: [listeners := nil]. ^listeners! ! !HandMorph methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:11'! adaptedToWorld: aWorld "If I refer to a world or a hand, return the corresponding items in the new world." ^aWorld primaryHand! ! !HandMorph methodsFor: 'private events' stamp: 'dgd 3/31/2003 18:22'! generateDropFilesEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" "Note: This is still in an experimental phase and will need more work" | position buttons modifiers stamp numFiles dragType | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. dragType := evtBuf third. position := evtBuf fourth @ evtBuf fifth. buttons := 0. modifiers := evtBuf sixth. buttons := buttons bitOr: (modifiers bitShift: 3). numFiles := evtBuf seventh. dragType = 4 ifTrue: ["e.g., drop" owner borderWidth: 0. ^DropFilesEvent new setPosition: position contents: numFiles hand: self]. "the others are currently not handled by morphs themselves" dragType = 1 ifTrue: ["experimental drag enter" owner borderWidth: 4; borderColor: owner color asColor negated]. dragType = 2 ifTrue: ["experimental drag move" ]. dragType = 3 ifTrue: ["experimental drag leave" owner borderWidth: 0]. ^nil! ! !HandMorph methodsFor: 'private events' stamp: 'yo 7/25/2003 16:56'! generateKeyboardEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | buttons modifiers type pressType stamp char | stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. pressType := evtBuf fourth. pressType = EventKeyDown ifTrue: [type := #keyDown]. pressType = EventKeyUp ifTrue: [type := #keyUp]. pressType = EventKeyChar ifTrue: [type := #keystroke]. modifiers := evtBuf fifth. buttons := modifiers bitShift: 3. char _ self keyboardInterpreter nextCharFrom: Sensor firstEvt: evtBuf. ^ KeyboardEvent new setType: type buttons: buttons position: self position keyValue: char asciiValue hand: self stamp: stamp. ! ! !HandMorph methodsFor: 'private events' stamp: 'efc 8/18/2003 18:40'! generateMouseEvent: evtBuf "Generate the appropriate mouse event for the given raw event buffer" | position buttons modifiers type trail stamp oldButtons evtChanged | evtBuf first = lastEventBuffer first ifTrue: ["Workaround for Mac VM bug, *always* generating 3 events on clicks" evtChanged := false. 3 to: evtBuf size do: [:i | (lastEventBuffer at: i) = (evtBuf at: i) ifFalse: [evtChanged := true]]. evtChanged ifFalse: [^nil]]. stamp := evtBuf second. stamp = 0 ifTrue: [stamp := Time millisecondClockValue]. position := evtBuf third @ evtBuf fourth. buttons := evtBuf fifth. modifiers := evtBuf sixth. type := buttons = 0 ifTrue: [lastEventBuffer fifth = 0 ifTrue: [#mouseMove] ifFalse: [#mouseUp]] ifFalse: [lastEventBuffer fifth = 0 ifTrue: [#mouseDown] ifFalse: [#mouseMove]]. buttons := buttons bitOr: (modifiers bitShift: 3). oldButtons := lastEventBuffer fifth bitOr: (lastEventBuffer sixth bitShift: 3). lastEventBuffer := evtBuf. type == #mouseMove ifTrue: [trail := self mouseTrailFrom: evtBuf. ^MouseMoveEvent new setType: type startPoint: (self position) endPoint: trail last trail: trail buttons: buttons hand: self stamp: stamp]. ^MouseButtonEvent new setType: type position: position which: (oldButtons bitXor: buttons) buttons: buttons hand: self stamp: stamp! ! !HandMorph methodsFor: 'private events' stamp: 'dgd 2/22/2003 14:58'! mouseTrailFrom: currentBuf "Current event, a mouse event buffer, is about to be processed. If there are other similar mouse events queued up, then drop them from the queue, and report the positions inbetween." | nextEvent trail | trail := WriteStream on: (Array new: 1). trail nextPut: currentBuf third @ currentBuf fourth. [(nextEvent := Sensor peekEvent) isNil] whileFalse: [nextEvent first = currentBuf first ifFalse: [^trail contents "different event type"]. nextEvent fifth = currentBuf fifth ifFalse: [^trail contents "buttons changed"]. nextEvent sixth = currentBuf sixth ifFalse: [^trail contents "modifiers changed"]. "nextEvent is similar. Remove it from the queue, and check the next." nextEvent := Sensor nextEvent. trail nextPut: nextEvent third @ nextEvent fourth]. ^trail contents! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:43'! sendEvent: anEvent focus: focusHolder "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^self sendEvent: anEvent focus: focusHolder clear:[nil]! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! sendEvent: anEvent focus: focusHolder clear: aBlock "Send the event to the morph currently holding the focus, or if none to the owner of the hand." | result | focusHolder ifNotNil:[^self sendFocusEvent: anEvent to: focusHolder clear: aBlock]. ActiveEvent _ anEvent. result _ owner processEvent: anEvent. ActiveEvent _ nil. ^result! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:42'! sendFocusEvent: anEvent to: focusHolder clear: aBlock "Send the event to the morph currently holding the focus" | result w | w _ focusHolder world ifNil:[^ aBlock value]. w becomeActiveDuring:[ ActiveHand _ self. ActiveEvent _ anEvent. result _ focusHolder handleFocusEvent: (anEvent transformedBy: (focusHolder transformedFrom: self)). ]. ^result! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:46'! sendKeyboardEvent: anEvent "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^self sendEvent: anEvent focus: self keyboardFocus clear:[self keyboardFocus: nil]! ! !HandMorph methodsFor: 'private events' stamp: 'ar 3/18/2001 01:45'! sendMouseEvent: anEvent "Send the event to the morph currently holding the focus, or if none to the owner of the hand." ^self sendEvent: anEvent focus: self mouseFocus clear:[self mouseFocus: nil]! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:06'! autoFocusRectangleBoundsFor: aMorph ^aMorph bounds! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:15'! disableGenieFocus ! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:47'! enableGenie self error: 'Genie is not available for this hand'.! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:44'! focusStartEvent ^nil! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 10:06'! genieGestureProcessor ^nil! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:45'! isGenieAvailable "Answer whether the Genie gesture recognizer is available for this hand" ^false! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:46'! isGenieEnabled "Answer whether the Genie gesture recognizer is enabled for this hand" ^false! ! !HandMorph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:46'! isGenieFocused "Answer whether the Genie gesture recognizer is auto-focused for this hand" ^false! ! !HandMorph methodsFor: 'multilingual' stamp: 'yo 9/26/2003 22:11'! clearKeyboardInterpreter keyboardInterpreter _ nil. ! ! !HandMorph methodsFor: 'multilingual' stamp: 'yo 7/28/2004 21:35'! keyboardInterpreter ^keyboardInterpreter ifNil: [keyboardInterpreter _ LanguageEnvironment currentPlatform class defaultInputInterpreter]! ! !HandMorph class methodsFor: 'accessing' stamp: 'nk 7/30/2004 21:39'! compositionWindowManager CompositionWindowManager ifNotNil: [^CompositionWindowManager]. SmalltalkImage current platformName = 'Win32' ifTrue: [^CompositionWindowManager := ImmWin32 new]. (SmalltalkImage current platformName = 'unix' and: [(SmalltalkImage current getSystemAttribute: 1005) = 'X11']) ifTrue: [^CompositionWindowManager := ImmX11 new]. ^CompositionWindowManager := ImmAbstractPlatform new! ! !HandMorph class methodsFor: 'class initialization' stamp: 'kfr 7/13/2003 14:15'! initialize "HandMorph initialize" PasteBuffer _ nil. DoubleClickTime _ 350. NormalCursor _ CursorWithMask normal asCursorForm. ! ! !HandMorph class methodsFor: 'utilities' stamp: 'nk 7/20/2003 10:03'! showEvents: aBool "HandMorph showEvents: true" "HandMorph showEvents: false" ShowEvents _ aBool. aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].! ! !HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:49'! clearCompositionWindowManager CompositionWindowManager _ nil. ! ! !HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:45'! clearInterpreters self allInstances do: [:each | each clearKeyboardInterpreter]. ! ! !HandMorph class methodsFor: 'initialization' stamp: 'yo 8/13/2003 15:49'! startUp self clearCompositionWindowManager. self clearInterpreters. ! ! !HandMorphForReplay methodsFor: 'event handling' stamp: 'dgd 2/22/2003 13:25'! processEvents "Play back the next event" | evt hadMouse hadAny | hadMouse := hadAny := false. [(evt := recorder nextEventToPlay) isNil] whileFalse: [evt type == #EOF ifTrue: [recorder pauseIn: self world. ^self]. evt type == #startSound ifTrue: [evt argument play. recorder synchronize. ^self]. evt isMouse ifTrue: [hadMouse := true]. (evt isMouse or: [evt isKeyboard]) ifTrue: [self handleEvent: (evt setHand: self) resetHandlerFields. hadAny := true]]. (mouseClickState notNil and: [hadMouse not]) ifTrue: ["No mouse events during this cycle. Make sure click states time out accordingly" mouseClickState handleEvent: lastMouseEvent asMouseMove from: self]. hadAny ifFalse: ["No pending events. Make sure z-order is up to date" self mouseOverHandler processMouseOver: lastMouseEvent]! ! !HandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:30'! initialize "initialize the state of the receiver" super initialize. "" self extent: 8 @ 8. ! ! !HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15'! stepTime "Update every hundredth of a second." ^ 10 ! ! !HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'! setUp "subclasses will add their prototypes into this collection" prototypes _ OrderedCollection new ! ! !HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! testEquality "Check that TextFontChanges report equality correctly" prototypes do: [:p | self should: [(EqualityTester with: p) result]] ! ! !HashAndEqualsTestCase methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! testHash "test that TextFontChanges hash correctly" prototypes do: [:p | self should: [(HashTester with: p) result]] ! ! !HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37' prior: 0! I am a simple TestCase that tests for correct operation of #hash and #=. Subclasses of me need to fill my prototypes with suitable objects to be tested.! !HashTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! resultFor: runs "Test that the hash is the same over runs and answer the result" | hash | hash _ self prototype hash. 1 to: runs do: [:i | hash = self prototype hash ifFalse: [^ false]]. ^ true ! ! !HashTester commentStamp: 'mjr 8/20/2003 12:48' prior: 0! I provide a simple way to test the hash properties of any object. I am given an object that should be tested and I treat it like a prototype. I take a copy of it when I am given it so that it can't change whilst I am holding on to it. I can then test that multiple copies of this object all hash to the same value.! !HashTesterTest methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! testBasicBehaviour self should: [(HashTester with: 1) resultFor: 100]. self should: [(HashTester with: 'fred') resultFor: 100]. self shouldnt: [(HashTester with: BadHasher new) resultFor: 100] ! ! !HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0! I am a simple test case to check that HashTester works correctly! !HeadMorph methodsFor: 'furnitures' stamp: 'dgd 3/7/2003 14:31'! addRandomFurnitures self perform: #(#yourself #addBeret #addHighHat #addAfroHair #addShortHair #addSpikyHair ) atRandom. self perform: #(#yourself #yourself #addShortMustache ) atRandom! ! !HeadMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:32'! defaultColor "answer the default color/fill style for the receiver" ^ {Color r: 0.258 g: 0.161 b: 0.0. Color r: 0.452 g: 0.258 b: 0.0. Color r: 0.516 g: 0.323 b: 0.0. Color r: 1.0 g: 0.935 b: 0.645. Color r: 1.0 g: 0.806 b: 0.548} atRandom! ! !HeadMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:32'! initialize "initialize the state of the receiver" super initialize. "" self face: FaceMorph new. self extent: self face extent * (1.5 @ 1.7). self face align: self face center with: self center + (0 @ self height // 10). self addRandomFurnitures. queue _ SharedQueue new! ! !HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:34'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:33'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.6 g: 1.0 b: 1.0! ! !HeadingMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:34'! initialize "initialize the state of the receiver" super initialize. "" degrees _ 90.0. magnitude _ 1.0. self extent: 160 @ 160! ! !HeadingMorph methodsFor: 'events' stamp: 'mk 11/7/2003 11:35'! mouseDown: evt | v | self changed. v _ evt cursorPoint - bounds center. degrees _ v theta radiansToDegrees. magnitude _ (v r asFloat / (bounds width asFloat / 2.0)) min: 1.0. ! ! !HeadingMorph methodsFor: 'events' stamp: 'mk 11/7/2003 11:36'! mouseMove: evt self mouseDown: evt! ! !Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! isHeap ^ true! ! !Heap methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:05'! = anObject ^ self == anObject ifTrue: [true] ifFalse: [anObject isHeap ifTrue: [sortBlock = anObject sortBlock and: [super = anObject]] ifFalse: [super = anObject]]! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 5/23/2001 17:22'! withAll: aCollection sortBlock: sortBlock "Create a new heap with all the elements from aCollection" ^(self basicNew) setCollection: aCollection asArray copy tally: aCollection size; sortBlock: sortBlock; yourself! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'jrp 8/28/2004 14:53'! privateInitializeFromText: aString | remainder ind specifiedSchemeName | remainder _ aString. schemeName ifNil: [specifiedSchemeName _ Url schemeNameForString: remainder. specifiedSchemeName ifNotNil: [schemeName _ specifiedSchemeName. remainder _ remainder copyFrom: schemeName size + 2 to: remainder size]. schemeName ifNil: ["assume HTTP" schemeName _ 'http']]. "remove leading // if it's there" (remainder beginsWith: '//') ifTrue: [remainder _ remainder copyFrom: 3 to: remainder size]. "get the query" ind _ remainder indexOf: $?. ind > 0 ifTrue: [query _ remainder copyFrom: ind + 1 to: remainder size. remainder _ remainder copyFrom: 1 to: ind - 1]. "get the authority" ind _ remainder indexOf: $/. ind > 0 ifTrue: [ind = 1 ifTrue: [authority _ ''] ifFalse: [authority _ remainder copyFrom: 1 to: ind - 1. remainder _ remainder copyFrom: ind + 1 to: remainder size]] ifFalse: [authority _ remainder. remainder _ '']. "extract the username+password" (authority includes: $@) ifTrue: [username _ authority copyUpTo: $@. authority _ authority copyFrom: (authority indexOf: $@) + 1 to: authority size. (username includes: $:) ifTrue: [password _ username copyFrom: (username indexOf: $:) + 1 to: username size. username _ username copyUpTo: $:]]. "Extract the port" (authority includes: $:) ifTrue: [| lastColonIndex portString | lastColonIndex _ authority findLast: [:c | c = $:]. portString _ authority copyFrom: lastColonIndex + 1 to: authority size. portString isAllDigits ifTrue: [port _ Integer readFromString: portString. (port > 65535) ifTrue: [self error: 'Invalid port number']. authority _ authority copyFrom: 1 to: lastColonIndex - 1] ifFalse:[self error: 'Invalid port number']]. "get the path" path _ self privateParsePath: remainder relativeTo: #() .! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 6/15/2003 13:40'! privateInitializeFromText: aString relativeTo: aUrl | remainder ind basePath | remainder _ aString. "set the scheme" schemeName _ aUrl schemeName. "a leading // means the authority is specified, meaning it is absolute" (remainder beginsWith: '//') ifTrue: [^ self privateInitializeFromText: aString]. "otherwise, use the same authority" authority _ aUrl authority. port _ aUrl port. username _ aUrl username. password _ aUrl password. "get the query" ind _ remainder indexOf: $?. ind > 0 ifTrue: [query _ remainder copyFrom: ind + 1 to: remainder size. remainder _ remainder copyFrom: 1 to: ind - 1]. "get the path" (remainder beginsWith: '/') ifTrue: [ basePath := #() ] ifFalse: [ basePath := aUrl path ]. path := self privateParsePath: remainder relativeTo: basePath. ! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'ls 7/21/2003 11:55'! privateParsePath: remainder relativeTo: basePath | nextTok s parsedPath | s := ReadStream on: remainder. parsedPath := OrderedCollection new. parsedPath addAll: basePath. parsedPath isEmpty ifFalse: [ parsedPath removeLast ]. [s peek = $/ ifTrue: [s next]. nextTok := WriteStream on: String new. [s atEnd or: [s peek = $/]] whileFalse: [nextTok nextPut: s next]. nextTok := nextTok contents unescapePercents. nextTok = '..' ifTrue: [parsedPath size > 0 ifTrue: [parsedPath removeLast]] ifFalse: [nextTok ~= '.' ifTrue: [parsedPath add: nextTok]]. s atEnd] whileFalse. parsedPath isEmpty ifTrue: [parsedPath add: '']. ^parsedPath! ! !HierarchicalUrl methodsFor: 'printing' stamp: 'ls 6/15/2003 13:27'! toText | ans | ans _ WriteStream on: String new. ans nextPutAll: self schemeName. ans nextPutAll: '://'. self username ifNotNil: [ ans nextPutAll: self username. self password ifNotNil: [ ans nextPutAll: ':'. ans nextPutAll: self password ]. ans nextPutAll: '@' ]. ans nextPutAll: self authority. port ifNotNil: [ans nextPut: $:; print: port]. path do: [ :pathElem | ans nextPut: $/. ans nextPutAll: pathElem encodeForHTTP. ]. self query isNil ifFalse: [ ans nextPut: $?. ans nextPutAll: self query. ]. self fragment isNil ifFalse: [ ans nextPut: $#. ans nextPutAll: self fragment encodeForHTTP. ]. ^ans contents! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! password "http://user:pword@foo.com' asUrl password" ^password! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! username "http://user:pword@foo.com' asUrl username" ^username! ! !HierarchicalUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:07'! scheme ^ self schemeName.! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! defaultBrowserTitle ^ 'Hierarchy Browser'! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'rhi 12/2/2001 21:32'! updateAfterClassChange "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser." (centralClass notNil and: [centralClass isObsolete not]) ifTrue: [self initHierarchyForClass: centralClass]! ! !HierarchyBrowser methodsFor: 'class list' stamp: 'sw 3/24/2002 01:55'! assureSelectionsShow "This is a workaround for the fact that a hierarchy browser, when launched, often does not show the selected class" | saveCatIndex saveMsgIndex | saveCatIndex _ messageCategoryListIndex. saveMsgIndex _ messageListIndex. self classListIndex: classListIndex. self messageCategoryListIndex: saveCatIndex. self messageListIndex: saveMsgIndex! ! !HierarchyBrowser class methodsFor: 'as yet unclassified' stamp: 'dew 9/15/2001 16:19'! newFor: aClass "Open a new HierarchyBrowser on the given class" | newBrowser | newBrowser _ HierarchyBrowser new initHierarchyForClass: aClass. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: newBrowser labelString "HierarchyBrowser newFor: Boolean"! ! !HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'! baseKern ^0! ! !HostFont methodsFor: 'accessing' stamp: 'yo 2/13/2004 04:06'! createCharacterToGlyphMap ^ IdentityGlyphMap new. ! ! !HostFont methodsFor: 'accessing' stamp: 'ar 2/2/2002 18:49'! descentKern ^0! ! !HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 12:03'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. ! ! !HostFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 15:14'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY ^ super displayMultiString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY. ! ! !HostFont methodsFor: 'accessing' stamp: 'ar 2/18/2001 20:01'! getFontData | fontHandle bufSize buffer | fontHandle _ self primitiveCreateFont: name size: pointSize emphasis: emphasis. fontHandle ifNil:[^nil]. bufSize _ self primitiveFontDataSize: fontHandle. buffer _ ByteArray new: bufSize. self primitiveFont: fontHandle getData: buffer. ^buffer! ! !HostFont methodsFor: 'accessing' stamp: 'ar 2/18/2001 20:04'! testEmbeddingFlags "HostFont basicNew testEmbeddingFlags" | list fontHandle | list _ self class listFontNames. list do:[:fName| fontHandle _ self primitiveCreateFont: fName size: 12 emphasis: 0. fontHandle ifNotNil:[ type _ self primitiveFontEmbeddingFlags: fontHandle. Transcript cr; show: fName,': ', type printString. self primitiveDestroyFont: fontHandle. ]. ].! ! !HostFont methodsFor: 'accessing' stamp: 'yo 2/17/2004 16:23'! widthOfString: aString from: firstIndex to: lastIndex ^ (aString copyFrom: firstIndex to: lastIndex) inject: 0 into: [:s :t | s _ s + (self widthOf: t)].! ! !HostFont methodsFor: 'emphasis' stamp: 'ar 8/29/2000 21:18'! emphasized: code | derivative addedEmphasis base safeCode | code = 0 ifTrue: [^ self]. derivativeFonts == nil ifTrue:[derivativeFonts _ Array new: 32]. derivative _ derivativeFonts at: (safeCode _ code min: derivativeFonts size). derivative == nil ifFalse: [^ derivative]. "Already have this style" "Dont have it -- derive from another with one with less emphasis" addedEmphasis _ 1 bitShift: safeCode highBit - 1. base _ self emphasized: safeCode - addedEmphasis. "Order is Bold, Ital, Under, Narrow" addedEmphasis = 1 ifTrue: "Compute synthetic bold version of the font" [derivative _ (base copy name: base name) makeBoldGlyphs]. addedEmphasis = 2 ifTrue: "Compute synthetic italic version of the font" [ derivative _ (base copy name: base name) makeItalicGlyphs]. addedEmphasis = 4 ifTrue: "Compute underlined version of the font" [derivative _ (base copy name: base name) makeUnderlinedGlyphs]. addedEmphasis = 8 ifTrue: "Compute narrow version of the font" [derivative _ (base copy name: base name) makeCondensedGlyphs]. addedEmphasis = 16 ifTrue: "Compute struck-out version of the font" [derivative _ (base copy name: base name) makeStruckOutGlyphs]. derivative emphasis: safeCode. derivativeFonts at: safeCode put: derivative. ^ derivative! ! !HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:38'! makeBoldGlyphs "First check if we can use some OS support for this" (self class listFontNames includes: name) ifFalse:[^super makeBoldGlyphs]. "Now attempt a direct creation through the appropriate primitives" (self fontName: name size: pointSize emphasis: (emphasis bitOr: 1) rangesArray: ranges) ifNil:[^super makeBoldGlyphs]. "nil means we failed"! ! !HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'! makeItalicGlyphs "First check if we can use some OS support for this" (self class listFontNames includes: name) ifFalse:[^super makeItalicGlyphs]. "Now attempt a direct creation through the appropriate primitives" (self fontName: name size: pointSize emphasis: (emphasis bitOr: 2) rangesArray: ranges) ifNil:[^super makeItalicGlyphs]. "nil means we failed"! ! !HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:39'! makeStruckOutGlyphs "First check if we can use some OS support for this" (self class listFontNames includes: name) ifFalse:[^super makeStruckOutGlyphs]. "Now attempt a direct creation through the appropriate primitives" (self fontName: name size: pointSize emphasis: (emphasis bitOr: 8) rangesArray: ranges) ifNil:[^super makeStruckOutGlyphs]. "nil means we failed"! ! !HostFont methodsFor: 'emphasis' stamp: 'yo 2/14/2004 01:40'! makeUnderlinedGlyphs "First check if we can use some OS support for this" (self class listFontNames includes: name) ifFalse:[^super makeUnderlinedGlyphs]. "Now attempt a direct creation through the appropriate primitives" (self fontName: name size: pointSize emphasis: (emphasis bitOr: 4) rangesArray: ranges) ifNil:[^super makeUnderlinedGlyphs]. "nil means we failed"! ! !HostFont methodsFor: 'private-creation' stamp: 'yo 2/14/2004 01:38'! fontName: fontName size: ptSize emphasis: emphasisCode ^ self fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: (Array with: (Array with: 0 with: 255)). ! ! !HostFont methodsFor: 'private-creation' stamp: 'yo 2/14/2004 01:41'! fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: rangesArray " ^HostFont fontName: ('MS UI Gothic') size: 12 emphasis: 0 rangesArray: EFontBDFFontReaderForRanges basicNew rangesForJapanese. " | fontHandle xStart w glyphForm fontHeight fw enc rangesStream currentRange | fontHandle _ self primitiveCreateFont: fontName size: ptSize emphasis: emphasisCode. fontHandle ifNil:[^nil]. ranges _ rangesArray. ranges ifNil: [ranges _ Array with: (Array with: 0 with: 255)]. pointSize _ ptSize. name _ fontName. emphasis _ emphasisCode. minAscii _ 0. maxAscii _ ranges last last. ascent _ self primitiveFontAscent: fontHandle. descent _ self primitiveFontDescent: fontHandle. kernPairs _ Array new: (self primitiveFontNumKernPairs: fontHandle). 1 to: kernPairs size do:[:i| kernPairs at: i put: (self primitiveFont: fontHandle getKernPair: i)]. fontHeight _ ascent + descent. xTable _ Array new: maxAscii + 3. fullWidth _ Array new: maxAscii + 1. xStart _ maxWidth _ 0. rangesStream _ ReadStream on: (ranges collect: [:e | (e first to: e second)]). currentRange _ rangesStream next. 0 to: maxAscii do:[:i| xTable at: i+1 put: xStart. i > currentRange last ifTrue: [ [rangesStream atEnd not and: [currentRange _ rangesStream next. currentRange last < i]] whileTrue. rangesStream atEnd ifTrue: []. ]. (currentRange includes: i) ifTrue: [ xTable at: i+1 put: xStart. fw _ self primitiveFont: fontHandle fullWidthOfChar: i. (#( 1 "anchored morph" 9 "tab" 10 "LF" 13 "CR" ) includes: i) ifTrue:[fw := {0. 0. 0}]. fullWidth at: i+1 put: fw. w _ fw at: 2. (fw at: 1) > 0 ifTrue:[w _ w + (fw at: 1)]. (fw at: 3) > 0 ifTrue:[w _ w + (fw at: 3)]. w > maxWidth ifTrue:[maxWidth _ w]. xStart _ xStart + w]. ]. xStart = 0 ifTrue:[^nil]. strikeLength _ xStart. xTable at: maxAscii+1 put: xStart. xTable at: maxAscii+2 put: xStart. xTable at: maxAscii+3 put: xStart. glyphs _ Form extent: xTable last @ fontHeight depth: 1. glyphForm _ Form extent: maxWidth @ fontHeight depth: 1. 0 to: maxAscii do:[:i| glyphForm fillWhite. self primitiveFont: fontHandle glyphOfChar: i into: glyphForm. xStart _ xTable at: i+1. glyphForm displayOn: glyphs at: xStart@0. "glyphForm displayOn: Display at: xStart@0." ]. enc := self primitiveFontEncoding: fontHandle. enc = 1 ifTrue:[characterToGlyphMap := self isoToSqueakMap]. self primitiveDestroyFont: fontHandle. ^self! ! !HostFont methodsFor: 'private-creation' stamp: 'yo 2/13/2004 02:53'! isoToSqueakMap ^nil ! ! !HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:11'! primitiveCreateFont: fontName size: fontSize emphasis: fontFlags <primitive:'primitiveCreateFont' module:'FontPlugin'> ^nil! ! !HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! primitiveDestroyFont: fontHandle <primitive:'primitiveDestroyFont' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! primitiveFont: fontHandle fullWidthOfChar: aCharIndex <primitive:'primitiveFontFullWidthOfChar' module:'FontPlugin'> ^Array with: 0 with: (self primitiveFont: fontHandle widthOfChar: aCharIndex) with: 0! ! !HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:46'! primitiveFont: fontHandle getData: buffer <primitive:'primitiveGetFontData' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:05'! primitiveFont: fontHandle getKernPair: kernIndex <primitive:'primitiveFontGetKernPair' module:'FontPlugin'> ^0! ! !HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! primitiveFont: fontHandle glyphOfChar: aCharIndex into: glyphForm <primitive:'primitiveFontGlyphOfChar' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'nk 8/31/2004 09:19'! primitiveFont: fontHandle widthOfChar: aCharIndex <primitive:'primitiveFontWidthOfChar' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! primitiveFontAscent: fontHandle <primitive:'primitiveFontAscent' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 19:45'! primitiveFontDataSize: fontHandle <primitive:'primitiveFontDataSize' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:01'! primitiveFontDescent: fontHandle <primitive:'primitiveFontDescent' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 2/18/2001 20:00'! primitiveFontEmbeddingFlags: fontHandle <primitive:'primitiveFontEmbeddingFlags' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 6/4/2000 23:02'! primitiveFontEncoding: fontHandle <primitive:'primitiveFontEncoding' module:'FontPlugin'> ^self primitiveFailed! ! !HostFont methodsFor: 'primitives' stamp: 'ar 8/28/2000 16:04'! primitiveFontNumKernPairs: fontHandle <primitive:'primitiveFontNumKernPairs' module:'FontPlugin'> ^0! ! !HostFont class methodsFor: 'instance creation' stamp: 'ar 6/4/2000 23:13'! fontName: fontName size: ptSize emphasis: emphasisCode " ^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0. " ^self new fontName: fontName size: ptSize emphasis: emphasisCode! ! !HostFont class methodsFor: 'instance creation' stamp: 'yo 2/14/2004 01:17'! fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges " ^HostFont fontName: (HostFont fontNameFromUser) size: 12 emphasis: 0. " ^self new fontName: fontName size: ptSize emphasis: emphasisCode rangesArray: ranges! ! !HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:50'! defaultRanges ^ Array with: (Array with: 0 with: 16r2AFF). ! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:03'! fontNameFromUser "HostFont fontNameFromUser" | fontNames index labels | fontNames _ self listFontNames asSortedCollection. labels _ WriteStream on: (String new: 100). fontNames do:[:fn| labels nextPutAll: fn] separatedBy:[labels cr]. index _ (PopUpMenu labels: labels contents) startUpWithCaption:'Choose your font'. index = 0 ifTrue:[^nil]. ^fontNames at: index! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:18'! listFontName: index <primitive:'primitiveListFont' module:'FontPlugin'> ^nil! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 6/4/2000 23:18'! listFontNames "HostFont listFontNames" "List all the OS font names" | font fontNames index | fontNames _ WriteStream on: Array new. index _ 0. [font _ self listFontName: index. font == nil] whileFalse:[ fontNames nextPut: font. index _ index + 1]. ^fontNames contents! ! !HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:57'! rangesForJapanese | basics etc | basics _ { Array with: 0 with: 255 }. etc _ { Array with: 16r370 with: 16r3FF. "greek" Array with: 16r400 with: 16r52F. "cyrillic" Array with: 16r1D00 with: 16r1D7F. "phonetic" Array with: 16r1E00 with: 16r1EFF. "latin extended additional" Array with: 16r2000 with: 16r206F. "general punctuation" Array with: 16r20A0 with: 16r20CF. "currency symbols" Array with: 16r2100 with: 16r214F. "letterlike" Array with: 16r2150 with: 16r218F. "number form" Array with: 16r2190 with: 16r21FF. "arrows" Array with: 16r2200 with: 16r22FF. "math operators" Array with: 16r2300 with: 16r23FF. "misc tech" Array with: 16r2460 with: 16r24FF. "enclosed alnum" Array with: 16r2500 with: 16r257F. "box drawing" Array with: 16r2580 with: 16r259F. "box elem" Array with: 16r25A0 with: 16r25FF. "geometric shapes" Array with: 16r2600 with: 16r26FF. "misc symbols" Array with: 16r2700 with: 16r27BF. "dingbats" Array with: 16r27C0 with: 16r27EF. "misc math A" Array with: 16r27F0 with: 16r27FF. "supplimental arrow A" Array with: 16r2900 with: 16r297F. "supplimental arrow B" Array with: 16r2980 with: 16r29FF. "misc math B" Array with: 16r2A00 with: 16r2AFF. "supplimental math op" Array with: 16r2900 with: 16r297F. "supplimental arrow B" Array with: 16r2E80 with: 16r2EFF. "cjk radicals suppliment" Array with: 16r2F00 with: 16r2FDF. "kangxi radicals" Array with: 16r3000 with: 16r303F. "cjk symbols" Array with: 16r3040 with: 16r309F. "hiragana" Array with: 16r30A0 with: 16r30FF. "katakana" Array with: 16r3190 with: 16r319F. "kanbun" Array with: 16r31F0 with: 16r31FF. "katakana extension" Array with: 16r3200 with: 16r32FF. "enclosed CJK" Array with: 16r3300 with: 16r33FF. "CJK compatibility" Array with: 16r3400 with: 16r4DBF. "CJK unified extension A" Array with: 16r4E00 with: 16r9FAF. "CJK ideograph" Array with: 16rF900 with: 16rFAFF. "CJK compatiblity ideograph" Array with: 16rFE30 with: 16rFE4F. "CJK compatiblity forms" Array with: 16rFF00 with: 16rFFEF. "half and full" }. ^ basics, etc. ! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 1/27/2002 19:37'! textStyleFrom: fontName "HostFont textStyleFromUser" | styleName fonts | styleName _ fontName asSymbol. "(TextConstants includesKey: styleName) ifTrue:[(self confirm: styleName , ' is already defined in TextConstants. Do you want to replace that definition?') ifFalse: [^ self]]." fonts _ #(10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90). ('Rendering ', styleName) displayProgressAt: Sensor cursorPoint from: 1 to: fonts size during:[:bar| fonts _ fonts collect:[:ptSize| bar value: (fonts indexOf: ptSize). self fontName: styleName size: ptSize emphasis: 0] thenSelect:[:font| font notNil]]. "reject those that failed" fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName]. TextConstants at: styleName put: (TextStyle fontArray: fonts).! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 1/27/2002 20:12'! textStyleFrom: fontName sizes: ptSizes | styleName fonts | styleName _ fontName asSymbol. (TextConstants includesKey: styleName) ifTrue:[(self confirm: styleName , ' is already defined in TextConstants. Do you want to replace that definition?') ifFalse: [^ self]]. ('Rendering ', styleName) displayProgressAt: Sensor cursorPoint from: 1 to: ptSizes size during:[:bar| fonts _ ptSizes collect:[:ptSize| bar value: (ptSizes indexOf: ptSize). self fontName: styleName size: ptSize emphasis: 0] thenSelect:[:font| font notNil]]. "reject those that failed" fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName]. TextConstants at: styleName put: (TextStyle fontArray: fonts).! ! !HostFont class methodsFor: 'accessing' stamp: 'yo 2/14/2004 01:26'! textStyleFrom: fontName sizes: ptSizes ranges: ranges | styleName fonts | styleName _ fontName asSymbol. (TextConstants includesKey: styleName) ifTrue:[(self confirm: styleName , ' is already defined in TextConstants. Do you want to replace that definition?') ifFalse: [^ self]]. ('Rendering ', styleName) displayProgressAt: Sensor cursorPoint from: 1 to: ptSizes size during:[:bar| fonts _ ptSizes collect:[:ptSize| bar value: (ptSizes indexOf: ptSize). self fontName: styleName size: ptSize emphasis: 0 rangesArray: ranges ] thenSelect:[:font| font notNil]]. "reject those that failed" fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName]. TextConstants at: styleName put: (TextStyle fontArray: fonts).! ! !HostFont class methodsFor: 'accessing' stamp: 'ar 8/28/2000 17:27'! textStyleFromUser "HostFont textStyleFromUser" | styleName fonts | styleName _ self fontNameFromUser ifNil:[^self]. styleName _ styleName asSymbol. (TextConstants includesKey: styleName) ifTrue:[(self confirm: styleName , ' is already defined in TextConstants. Do you want to replace that definition?') ifFalse: [^ self]]. fonts _ #(10 12 14 16 18 20 22 24 26 28 30 36 48 60 72 90). ('Rendering ', styleName) displayProgressAt: Sensor cursorPoint from: 1 to: fonts size during:[:bar| fonts _ fonts collect:[:ptSize| bar value: (fonts indexOf: ptSize). self fontName: styleName size: ptSize emphasis: 0] thenSelect:[:font| font notNil]]. "reject those that failed" fonts size = 0 ifTrue:[^self error:'Could not create font style', styleName]. TextConstants at: styleName put: (TextStyle fontArray: fonts).! ! !HostFont class methodsFor: 'system defaults' stamp: 'yo 3/17/2004 00:39'! initForSubtitles " HostFont initForSubtitles " HostFont textStyleFrom: 'Verdana' sizes: #(18 20 22 24 26 28) ranges: HostFont defaultRanges. StrikeFontSet installExternalFontFileName: 'greekFont.out' encoding: GreekEnvironment leadingChar encodingName: #Greek textStyleName: #DefaultMultiStyle. TTCFontReader encodingTag: SimplifiedChineseEnvironment leadingChar. TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\simhei.TTF'. TTCFontReader encodingTag: JapaneseEnvironment leadingChar. TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC'. TTCFontReader encodingTag: KoreanEnvironment leadingChar. TTCFontSet newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\gulim.TTC'. ! ! !HostFont class methodsFor: 'system defaults' stamp: 'yo 2/13/2004 23:25'! initWin32 "HostFont initWin32" #( "Basic fonts" ('Arial' "menu/text serifless" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Times New Roman' "menu/text serifs" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Courier New' "menu/text fixed" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Wingdings' "deco" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Symbol' "deco" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) "Nice fonts" ('Verdana' "menu/text serifless" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Tahoma' "menu/text serifless" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Garamond' "menu/text serifs" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Georgia' "menu/text serifs" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Comic Sans MS' "eToy" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) "Optional fonts" ('Impact' "flaps" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('Webdings' "deco" (10 11 12 13 14 16 18 20 22 24 26 28 30 36 48 60 72 90)) ('System' "12pt only" (12)) ('Fixedsys' "12pt only" (12)) ) do:[:spec| HostFont textStyleFrom: spec first sizes: spec last]. TextConstants removeKey: #Atlanta ifAbsent: []. TextConstants removeKey: #ComicPlain ifAbsent: []. TextConstants removeKey: #ComicBold ifAbsent: []. TextConstants removeKey: #Courier ifAbsent: []. TextConstants removeKey: #Palatino ifAbsent: []. TextConstants at: #DefaultFixedTextStyle put: (TextConstants at: #'Courier New'). TextConstants at: #Helvetica put: (TextConstants at: #'Arial'). ! ! !HostFont class methodsFor: 'system defaults' stamp: 'yo 12/2/2004 12:50'! unloadAsianTT " self unloadAsianTT " TTCFontSet removeStyleName: 'MultiSimHei'. TTCFontSet removeStyleName: 'MultiMSGothic'. TTCFontSet removeStyleName: 'MultiGulim'. ! ! !HttpUrl methodsFor: 'downloading' stamp: 'ar 3/18/2001 00:54'! askNamePassword "Authorization is required by the host site. Ask the user for a userName and password. Encode them and store under this realm. Return false if the user wants to give up." | user password | (self confirm: 'Host ', self toText, ' wants a different user and password. Type them now?' orCancel: [false]) ifFalse: [^ false]. "Note: When Scamper is converted to run under MVC, we'll have to pass in topView in order to decide which FillInTheBlank to call." user _ FillInTheBlank request: 'User account name?' initialAnswer: '' centerAt: (ActiveHand ifNil:[Sensor]) cursorPoint - (50@0). password _ FillInTheBlank requestPassword: 'Password?'. Passwords at: realm put: (Authorizer new encode: user password: password). ^ true! ! !HttpUrl methodsFor: 'downloading' stamp: 'nk 8/30/2004 07:50'! checkAuthorization: webDocument retry: retryBlock "authorization failed if webDocument is a String" | oldRealm i end encoded | ((webDocument isString) and: [(webDocument beginsWith: 'HTTP/1.0 401') or: [webDocument beginsWith: 'HTTP/1.1 401']]) ifFalse: [^self]. oldRealm _ realm. i _ webDocument findString: 'realm="'. i = 0 ifTrue: [^self]. end _ webDocument indexOf: $" startingAt: i. realm _ webDocument copyFrom: i+7 to: end. "realm _ (webDocument findTokens: '""') at: 2." Passwords ifNil: [Passwords _ Dictionary new]. encoded _ Passwords at: realm ifAbsent: [nil]. (oldRealm ~= realm) & (encoded ~~ nil) ifTrue: [^ retryBlock value] ifFalse: ["ask the user" self askNamePassword ifTrue: [^ retryBlock value]]! ! !HttpUrl methodsFor: 'downloading' stamp: 'nk 8/30/2004 07:50'! normalizeContents: webDocument (webDocument isString) ifTrue: [ ^MIMEDocument contentType: 'text/plain' content: 'error occured retrieving ', self toText, ': ', webDocument url: (Url absoluteFromText: '')]. webDocument contentType = MIMEDocument defaultContentType ifTrue: [ ^MIMEDocument contentType: (MIMEDocument guessTypeFromName: self path last) content: webDocument content url: webDocument url ]. ^webDocument! ! !HttpUrl methodsFor: 'testing' stamp: 'ar 2/27/2001 22:08'! hasRemoteContents "Return true if the receiver describes some remotely accessible content. Typically, this should only return if we could retrieve the contents on an arbitrary place in the outside world using a standard browser. In other words: If you can get to it from the next Internet Cafe, return true, else return false." ^true! ! !HttpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! A URL that can be accessed via the Hypertext Transfer Protocol (HTTP), ie, a standard Web URL realm = the name of the security realm that has been discovered for this URL. Look it up in Passwords. Passwords = a Dictionary of (realm -> encoded user&password) TODO: use the username and password, if specified ! !ISO88592ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:35'! fromSystemClipboard: aString ^ aString convertFromWithConverter: ISO88592TextConverter new. ! ! !ISO88592ClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'pk 1/4/2005 03:56'! toSystemClipboard: aString | result converter r | aString isAsciiString ifTrue: [^ aString asOctetString]. "optimization" result _ WriteStream on: (String new: aString size). converter _ ISO88592TextConverter new. aString do: [:each | r _ converter fromSqueak: each.]. ^ result contents. ! ! !ISO88592InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:58'! initialize converter _ ISO88592TextConverter new. ! ! !ISO88592InputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:58'! nextCharFrom: sensor firstEvt: evtBuf | keyValue | keyValue := evtBuf third. ^ converter toSqueak: keyValue asCharacter. ! ! !ISO88592TextConverter methodsFor: 'conversion' stamp: 'yo 1/18/2005 08:30'! nextFromStream: aStream | character1 | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. ^ self toSqueak: character1. ! ! !ISO88592TextConverter methodsFor: 'conversion' stamp: 'yo 1/18/2005 17:06'! nextPut: aCharacter toStream: aStream aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ aStream basicNextPut: aCharacter charCode. ^ aStream. ]. aCharacter class == MultiCharacter ifTrue: [ aStream nextInt32Put: aCharacter charCode. ^ aStream. ]. ]. aCharacter charCode < 128 ifTrue: [ aStream basicNextPut: aCharacter. ] ifFalse: [ aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)). ]. ! ! !ISO88592TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'! fromSqueak: char ^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! ! !ISO88592TextConverter methodsFor: 'private' stamp: 'yo 1/18/2005 09:20'! toSqueak: char | value | value _ char charCode. value < 160 ifTrue: [^ char]. value > 255 ifTrue: [^ char]. ^ MultiCharacter leadingChar: Latin2Environment leadingChar code: (#( 16r00A0 16r0104 16r02D8 16r0141 16r00A4 16r013D 16r015A 16r00A7 16r00A8 16r0160 16r015E 16r0164 16r0179 16r00AD 16r017D 16r017B 16r00B0 16r0105 16r02DB 16r0142 16r00B4 16r013E 16r015B 16r02C7 16r00B8 16r0161 16r015F 16r0165 16r017A 16r02DD 16r017E 16r017C 16r0154 16r00C1 16r00C2 16r0102 16r00C4 16r0139 16r0106 16r00C7 16r010C 16r00C9 16r0118 16r00CB 16r011A 16r00CD 16r00CE 16r010E 16r0110 16r0143 16r0147 16r00D3 16r00D4 16r0150 16r00D6 16r00D7 16r0158 16r016E 16r00DA 16r0170 16r00DC 16r00DD 16r0162 16r00DF 16r0155 16r00E1 16r00E2 16r0103 16r00E4 16r013A 16r0107 16r00E7 16r010D 16r00E9 16r0119 16r00EB 16r011B 16r00ED 16r00EE 16r010F 16r0111 16r0144 16r0148 16r00F3 16r00F4 16r0151 16r00F6 16r00F7 16r0159 16r016F 16r00FA 16r0171 16r00FC 16r00FD 16r0163 16r02D9 ) at: (value - 160 + 1)). ! ! !ISO88592TextConverter commentStamp: '<historical>' prior: 0! Text converter for ISO 8859-2. An international encoding used in Eastern Europe.! !ISO88592TextConverter class methodsFor: 'class initialization' stamp: 'yo 1/18/2005 09:17'! initialize " self initialize " FromTable _ Dictionary new. FromTable at: 16r00A0 put: 16rA0. FromTable at: 16r0104 put: 16rA1. FromTable at: 16r02D8 put: 16rA2. FromTable at: 16r0141 put: 16rA3. FromTable at: 16r00A4 put: 16rA4. FromTable at: 16r013D put: 16rA5. FromTable at: 16r015A put: 16rA6. FromTable at: 16r00A7 put: 16rA7. FromTable at: 16r00A8 put: 16rA8. FromTable at: 16r0160 put: 16rA9. FromTable at: 16r015E put: 16rAA. FromTable at: 16r0164 put: 16rAB. FromTable at: 16r0179 put: 16rAC. FromTable at: 16r00AD put: 16rAD. FromTable at: 16r017D put: 16rAE. FromTable at: 16r017B put: 16rAF. FromTable at: 16r00B0 put: 16rB0. FromTable at: 16r0105 put: 16rB1. FromTable at: 16r02DB put: 16rB2. FromTable at: 16r0142 put: 16rB3. FromTable at: 16r00B4 put: 16rB4. FromTable at: 16r013E put: 16rB5. FromTable at: 16r015B put: 16rB6. FromTable at: 16r02C7 put: 16rB7. FromTable at: 16r00B8 put: 16rB8. FromTable at: 16r0161 put: 16rB9. FromTable at: 16r015F put: 16rBA. FromTable at: 16r0165 put: 16rBB. FromTable at: 16r017A put: 16rBC. FromTable at: 16r02DD put: 16rBD. FromTable at: 16r017E put: 16rBE. FromTable at: 16r017C put: 16rBF. FromTable at: 16r0154 put: 16rC0. FromTable at: 16r00C1 put: 16rC1. FromTable at: 16r00C2 put: 16rC2. FromTable at: 16r0102 put: 16rC3. FromTable at: 16r00C4 put: 16rC4. FromTable at: 16r0139 put: 16rC5. FromTable at: 16r0106 put: 16rC6. FromTable at: 16r00C7 put: 16rC7. FromTable at: 16r010C put: 16rC8. FromTable at: 16r00C9 put: 16rC9. FromTable at: 16r0118 put: 16rCA. FromTable at: 16r00CB put: 16rCB. FromTable at: 16r011A put: 16rCC. FromTable at: 16r00CD put: 16rCD. FromTable at: 16r00CE put: 16rCE. FromTable at: 16r010E put: 16rCF. FromTable at: 16r0110 put: 16rD0. FromTable at: 16r0143 put: 16rD1. FromTable at: 16r0147 put: 16rD2. FromTable at: 16r00D3 put: 16rD3. FromTable at: 16r00D4 put: 16rD4. FromTable at: 16r0150 put: 16rD5. FromTable at: 16r00D6 put: 16rD6. FromTable at: 16r00D7 put: 16rD7. FromTable at: 16r0158 put: 16rD8. FromTable at: 16r016E put: 16rD9. FromTable at: 16r00DA put: 16rDA. FromTable at: 16r0170 put: 16rDB. FromTable at: 16r00DC put: 16rDC. FromTable at: 16r00DD put: 16rDD. FromTable at: 16r0162 put: 16rDE. FromTable at: 16r00DF put: 16rDF. FromTable at: 16r0155 put: 16rE0. FromTable at: 16r00E1 put: 16rE1. FromTable at: 16r00E2 put: 16rE2. FromTable at: 16r0103 put: 16rE3. FromTable at: 16r00E4 put: 16rE4. FromTable at: 16r013A put: 16rE5. FromTable at: 16r0107 put: 16rE6. FromTable at: 16r00E7 put: 16rE7. FromTable at: 16r010D put: 16rE8. FromTable at: 16r00E9 put: 16rE9. FromTable at: 16r0119 put: 16rEA. FromTable at: 16r00EB put: 16rEB. FromTable at: 16r011B put: 16rEC. FromTable at: 16r00ED put: 16rED. FromTable at: 16r00EE put: 16rEE. FromTable at: 16r010F put: 16rEF. FromTable at: 16r0111 put: 16rF0. FromTable at: 16r0144 put: 16rF1. FromTable at: 16r0148 put: 16rF2. FromTable at: 16r00F3 put: 16rF3. FromTable at: 16r00F4 put: 16rF4. FromTable at: 16r0151 put: 16rF5. FromTable at: 16r00F6 put: 16rF6. FromTable at: 16r00F7 put: 16rF7. FromTable at: 16r0159 put: 16rF8. FromTable at: 16r016F put: 16rF9. FromTable at: 16r00FA put: 16rFA. FromTable at: 16r0171 put: 16rFB. FromTable at: 16r00FC put: 16rFC. FromTable at: 16r00FD put: 16rFD. FromTable at: 16r0163 put: 16rFE. FromTable at: 16r02D9 put: 16rFF. ! ! !ISO88592TextConverter class methodsFor: 'utilities' stamp: 'yo 1/18/2005 09:17'! encodingNames ^ #('iso-8859-2') copy ! ! !ISO88597TextConverter methodsFor: 'conversion' stamp: 'yo 2/10/2004 06:28'! nextFromStream: aStream | character1 | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. ^ self toSqueak: character1. ! ! !ISO88597TextConverter methodsFor: 'conversion' stamp: 'yo 1/18/2005 17:10'! nextPut: aCharacter toStream: aStream aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ aStream basicNextPut: aCharacter charCode. ^ aStream. ]. aCharacter class == MultiCharacter ifTrue: [ aStream nextInt32Put: aCharacter charCode. ^ aStream. ]. ]. aCharacter charCode < 128 ifTrue: [ aStream basicNextPut: aCharacter. ] ifFalse: [ aStream basicNextPut: ((Character value: (self fromSqueak: aCharacter) charCode)). ]. ! ! !ISO88597TextConverter methodsFor: 'private' stamp: 'yo 2/9/2005 05:29'! fromSqueak: char ^ Character value: (FromTable at: char charCode ifAbsent: [char asciiValue])! ! !ISO88597TextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:39'! toSqueak: char | value | value _ char charCode. value < 160 ifTrue: [^ char]. value > 255 ifTrue: [^ char]. ^ MultiCharacter leadingChar: GreekEnvironment leadingChar code: (#( 16r00A0 16r2018 16r2019 16r00A3 16r20AC 16r20AF 16r00A6 16r00A7 16r00A8 16r00A9 16r037A 16r00AB 16r00AC 16r00AD 16rFFFD 16r2015 16r00B0 16r00B1 16r00B2 16r00B3 16r0384 16r0385 16r0386 16r00B7 16r0388 16r0389 16r038A 16r00BB 16r038C 16r00BD 16r038E 16r038F 16r0390 16r0391 16r0392 16r0393 16r0394 16r0395 16r0396 16r0397 16r0398 16r0399 16r039A 16r039B 16r039C 16r039D 16r039E 16r039F 16r03A0 16r03A1 16rFFFD 16r03A3 16r03A4 16r03A5 16r03A6 16r03A7 16r03A8 16r03A9 16r03AA 16r03AB 16r03AC 16r03AD 16r03AE 16r03AF 16r03B0 16r03B1 16r03B2 16r03B3 16r03B4 16r03B5 16r03B6 16r03B7 16r03B8 16r03B9 16r03BA 16r03BB 16r03BC 16r03BD 16r03BE 16r03BF 16r03C0 16r03C1 16r03C2 16r03C3 16r03C4 16r03C5 16r03C6 16r03C7 16r03C8 16r03C9 16r03CA 16r03CB 16r03CC 16r03CD 16r03CE 16rFFFD ) at: (value - 160 + 1)). ! ! !ISO88597TextConverter commentStamp: '<historical>' prior: 0! Text converter for ISO 8859-7. An international encoding used for Greek.! !ISO88597TextConverter class methodsFor: 'class initialization' stamp: 'yo 2/9/2004 17:36'! initialize " self initialize " FromTable _ Dictionary new. FromTable at: 16r00A0 put: 16rA0. FromTable at: 16r2018 put: 16rA1. FromTable at: 16r2019 put: 16rA2. FromTable at: 16r00A3 put: 16rA3. FromTable at: 16r20AC put: 16rA4. FromTable at: 16r20AF put: 16rA5. FromTable at: 16r00A6 put: 16rA6. FromTable at: 16r00A7 put: 16rA7. FromTable at: 16r00A8 put: 16rA8. FromTable at: 16r00A9 put: 16rA9. FromTable at: 16r037A put: 16rAA. FromTable at: 16r00AB put: 16rAB. FromTable at: 16r00AC put: 16rAC. FromTable at: 16r00AD put: 16rAD. FromTable at: 16r2015 put: 16rAF. FromTable at: 16r00B0 put: 16rB0. FromTable at: 16r00B1 put: 16rB1. FromTable at: 16r00B2 put: 16rB2. FromTable at: 16r00B3 put: 16rB3. FromTable at: 16r0384 put: 16rB4. FromTable at: 16r0385 put: 16rB5. FromTable at: 16r0386 put: 16rB6. FromTable at: 16r00B7 put: 16rB7. FromTable at: 16r0388 put: 16rB8. FromTable at: 16r0389 put: 16rB9. FromTable at: 16r038A put: 16rBA. FromTable at: 16r00BB put: 16rBB. FromTable at: 16r038C put: 16rBC. FromTable at: 16r00BD put: 16rBD. FromTable at: 16r038E put: 16rBE. FromTable at: 16r038F put: 16rBF. FromTable at: 16r0390 put: 16rC0. FromTable at: 16r0391 put: 16rC1. FromTable at: 16r0392 put: 16rC2. FromTable at: 16r0393 put: 16rC3. FromTable at: 16r0394 put: 16rC4. FromTable at: 16r0395 put: 16rC5. FromTable at: 16r0396 put: 16rC6. FromTable at: 16r0397 put: 16rC7. FromTable at: 16r0398 put: 16rC8. FromTable at: 16r0399 put: 16rC9. FromTable at: 16r039A put: 16rCA. FromTable at: 16r039B put: 16rCB. FromTable at: 16r039C put: 16rCC. FromTable at: 16r039D put: 16rCD. FromTable at: 16r039E put: 16rCE. FromTable at: 16r039F put: 16rCF. FromTable at: 16r03A0 put: 16rD0. FromTable at: 16r03A1 put: 16rD1. FromTable at: 16r03A3 put: 16rD3. FromTable at: 16r03A4 put: 16rD4. FromTable at: 16r03A5 put: 16rD5. FromTable at: 16r03A6 put: 16rD6. FromTable at: 16r03A7 put: 16rD7. FromTable at: 16r03A8 put: 16rD8. FromTable at: 16r03A9 put: 16rD9. FromTable at: 16r03AA put: 16rDA. FromTable at: 16r03AB put: 16rDB. FromTable at: 16r03AC put: 16rDC. FromTable at: 16r03AD put: 16rDD. FromTable at: 16r03AE put: 16rDE. FromTable at: 16r03AF put: 16rDF. FromTable at: 16r03B0 put: 16rE0. FromTable at: 16r03B1 put: 16rE1. FromTable at: 16r03B2 put: 16rE2. FromTable at: 16r03B3 put: 16rE3. FromTable at: 16r03B4 put: 16rE4. FromTable at: 16r03B5 put: 16rE5. FromTable at: 16r03B6 put: 16rE6. FromTable at: 16r03B7 put: 16rE7. FromTable at: 16r03B8 put: 16rE8. FromTable at: 16r03B9 put: 16rE9. FromTable at: 16r03BA put: 16rEA. FromTable at: 16r03BB put: 16rEB. FromTable at: 16r03BC put: 16rEC. FromTable at: 16r03BD put: 16rED. FromTable at: 16r03BE put: 16rEE. FromTable at: 16r03BF put: 16rEF. FromTable at: 16r03C0 put: 16rF0. FromTable at: 16r03C1 put: 16rF1. FromTable at: 16r03C2 put: 16rF2. FromTable at: 16r03C3 put: 16rF3. FromTable at: 16r03C4 put: 16rF4. FromTable at: 16r03C5 put: 16rF5. FromTable at: 16r03C6 put: 16rF6. FromTable at: 16r03C7 put: 16rF7. FromTable at: 16r03C8 put: 16rF8. FromTable at: 16r03C9 put: 16rF9. FromTable at: 16r03CA put: 16rFA. FromTable at: 16r03CB put: 16rFB. FromTable at: 16r03CC put: 16rFC. FromTable at: 16r03CD put: 16rFD. FromTable at: 16r03CE put: 16rFE. ! ! !ISO88597TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 06:32'! encodingNames ^ #('iso-8859-7' 'greek-iso-8859-8bit') copy ! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:20'! iso2 ^iso2 ifNil: [self iso3]! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:21'! iso3 ^iso3 ifNil: ['']! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 6/30/2004 15:47'! iso3Alternate ^iso3Alternate ifNil: ['']! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 8/15/2003 13:13'! language ^language! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso2: aString iso2 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3: aString iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3Alternate: aString iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 8/15/2003 13:40'! language: aString language := aString! ! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso2LanguageDefinition: aString ^self iso2LanguageTable at: aString! ! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso3LanguageDefinition: aString ^self iso3LanguageTable at: aString! ! !ISOLanguageDefinition class methodsFor: 'class initialization' stamp: 'mir 7/1/2004 18:19'! initialize "ISOLanguageDefinition initialize" ISO3Table := nil. ISO2Table := nil! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:09'! convertISOCountriesFrom: stream "Locale convertISOCountriesFrom: Locale isoCountries readStream " | line c3 c2 | ^String streamContents: [:outStream | [stream atEnd or: [(line := stream nextLine readStream) atEnd]] whileFalse: [ c3 := line upTo: Character tab. c2 := line upToEnd. outStream nextPutAll: c2; tab; nextPutAll: c3; cr]]! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:20'! extraCountryDefinitions ^self readISOCountriesFrom: 'KIDS Kids ' readStream! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:14'! extraISO3Definitions ^self readISOLanguagesFrom: 'jpk Japanese (Kids) ' readStream! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:13'! initISO3LanguageTable "ISOLanguageDefinition initIso3LanguageTable" | table | table := ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream. table addAll: self extraISO3Definitions. ^table! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:16'! initISOCountries | countries | countries := self readISOCountriesFrom: self isoCountryString readStream. countries addAll: self extraCountryDefinitions. ^countries! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:14'! iso2LanguageTable "ISOLanguageDefinition iso2LanguageTable" ISO2Table ifNotNil: [^ISO2Table]. ISO2Table := Dictionary new: self iso3LanguageTable basicSize. self iso3LanguageTable do: [:entry | ISO2Table at: entry iso2 put: entry]. ^ISO2Table! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/21/2004 13:10'! iso3LanguageTable "ISOLanguageDefinition iso3LanguageTable" ^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:20'! isoCountries "ISOLanguageDefinition isoCountries" "ISOCountries := nil" ^ISOCountries ifNil: [ISOCountries := self initISOCountries]! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'yo 12/3/2004 17:47'! isoCountryString "This list states the country names (official short names in English) in alphabetical order as given in ISO 3166-1 and the corresponding ISO 3166-1-alpha-2 code elements. The list is updated whenever a change to the official code list in ISO 3166-1 is effected by the ISO 3166/MA. It lists 240 official short names and code elements. One line of text contains one entry. A country name and its code element are separated by a semicolon (;)." ^'AF AFGHANISTAN AX Ã…LAND ISLANDS AL ALBANIA DZ ALGERIA AS AMERICAN SAMOA AD ANDORRA AO ANGOLA AI ANGUILLA AQ ANTARCTICA AG ANTIGUA AND BARBUDA AR ARGENTINA AM ARMENIA AW ARUBA AU AUSTRALIA AT AUSTRIA AZ AZERBAIJAN BS BAHAMAS BH BAHRAIN BD BANGLADESH BB BARBADOS BY BELARUS BE BELGIUM BZ BELIZE BJ BENIN BM BERMUDA BT BHUTAN BO BOLIVIA BA BOSNIA AND HERZEGOVINA BW BOTSWANA BV BOUVET ISLAND BR BRAZIL IO BRITISH INDIAN OCEAN TERRITORY BN BRUNEI DARUSSALAM BG BULGARIA BF BURKINA FASO BI BURUNDI KH CAMBODIA CM CAMEROON CA CANADA CV CAPE VERDE KY CAYMAN ISLANDS CF CENTRAL AFRICAN REPUBLIC TD CHAD CL CHILE CN CHINA CX CHRISTMAS ISLAND CC COCOS (KEELING) ISLANDS CO COLOMBIA KM COMOROS CG CONGO CD CONGO, THE DEMOCRATIC REPUBLIC OF THE CK COOK ISLANDS CR COSTA RICA CI COTE D''IVOIRE HR CROATIA CU CUBA CY CYPRUS CZ CZECH REPUBLIC DK DENMARK DJ DJIBOUTI DM DOMINICA DO DOMINICAN REPUBLIC EC ECUADOR EG EGYPT SV EL SALVADOR GQ EQUATORIAL GUINEA ER ERITREA EE ESTONIA ET ETHIOPIA FK FALKLAND ISLANDS (MALVINAS) FO FAROE ISLANDS FJ FIJI FI FINLAND FR FRANCE GF FRENCH GUIANA PF FRENCH POLYNESIA TF FRENCH SOUTHERN TERRITORIES GA GABON GM GAMBIA GE GEORGIA DE GERMANY GH GHANA GI GIBRALTAR GR GREECE GL GREENLAND GD GRENADA GP GUADELOUPE GU GUAM GT GUATEMALA GN GUINEA GW GUINEA-BISSAU GY GUYANA HT HAITI HM HEARD ISLAND AND MCDONALD ISLANDS VA HOLY SEE (VATICAN CITY STATE) HN HONDURAS HK HONG KONG HU HUNGARY IS ICELAND IN INDIA ID INDONESIA IR IRAN, ISLAMIC REPUBLIC OF IQ IRAQ IE IRELAND IL ISRAEL IT ITALY JM JAMAICA JP JAPAN JO JORDAN KZ KAZAKHSTAN KE KENYA KI KIRIBATI KP KOREA, DEMOCRATIC PEOPLE''S REPUBLIC OF KR KOREA, REPUBLIC OF KW KUWAIT KG KYRGYZSTAN LA LAO PEOPLE''S DEMOCRATIC REPUBLIC LV LATVIA LB LEBANON LS LESOTHO LR LIBERIA LY LIBYAN ARAB JAMAHIRIYA LI LIECHTENSTEIN LT LITHUANIA LU LUXEMBOURG MO MACAO MK MACEDONIA, THE FORMER YUGOSLAV REPUBLIC OF MG MADAGASCAR MW MALAWI MY MALAYSIA MV MALDIVES ML MALI MT MALTA MH MARSHALL ISLANDS MQ MARTINIQUE MR MAURITANIA MU MAURITIUS YT MAYOTTE MX MEXICO FM MICRONESIA, FEDERATED STATES OF MD MOLDOVA, REPUBLIC OF MC MONACO MN MONGOLIA MS MONTSERRAT MA MOROCCO MZ MOZAMBIQUE MM MYANMAR NA NAMIBIA NR NAURU NP NEPAL NL NETHERLANDS AN NETHERLANDS ANTILLES NC NEW CALEDONIA NZ NEW ZEALAND NI NICARAGUA NE NIGER NG NIGERIA NU NIUE NF NORFOLK ISLAND MP NORTHERN MARIANA ISLANDS NO NORWAY OM OMAN PK PAKISTAN PW PALAU PS PALESTINIAN TERRITORY, OCCUPIED PA PANAMA PG PAPUA NEW GUINEA PY PARAGUAY PE PERU PH PHILIPPINES PN PITCAIRN PL POLAND PT PORTUGAL PR PUERTO RICO QA QATAR RE REUNION RO ROMANIA RU RUSSIAN FEDERATION RW RWANDA SH SAINT HELENA KN SAINT KITTS AND NEVIS LC SAINT LUCIA PM SAINT PIERRE AND MIQUELON VC SAINT VINCENT AND THE GRENADINES WS SAMOA SM SAN MARINO ST SAO TOME AND PRINCIPE SA SAUDI ARABIA SN SENEGAL CS SERBIA AND MONTENEGRO SC SEYCHELLES SL SIERRA LEONE SG SINGAPORE SK SLOVAKIA SI SLOVENIA SB SOLOMON ISLANDS SO SOMALIA ZA SOUTH AFRICA GS SOUTH GEORGIA AND THE SOUTH SANDWICH ISLANDS ES SPAIN LK SRI LANKA SD SUDAN SR SURINAME SJ SVALBARD AND JAN MAYEN SZ SWAZILAND SE SWEDEN CH SWITZERLAND SY SYRIAN ARAB REPUBLIC TW TAIWAN, PROVINCE OF CHINA TJ TAJIKISTAN TZ TANZANIA, UNITED REPUBLIC OF TH THAILAND TL TIMOR-LESTE TG TOGO TK TOKELAU TO TONGA TT TRINIDAD AND TOBAGO TN TUNISIA TR TURKEY TM TURKMENISTAN TC TURKS AND CAICOS ISLANDS TV TUVALU UG UGANDA UA UKRAINE AE UNITED ARAB EMIRATES GB UNITED KINGDOM US UNITED STATES UM UNITED STATES MINOR OUTLYING ISLANDS UY URUGUAY UZ UZBEKISTAN VU VANUATU VE VENEZUELA VN VIET NAM VG VIRGIN ISLANDS, BRITISH VI VIRGIN ISLANDS, U.S. WF WALLIS AND FUTUNA EH WESTERN SAHARA YE YEMEN ZM ZAMBIA ZW ZIMBABWE'! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'yo 12/3/2004 17:46'! isoLanguages "ISO 639: 3-letter codes" ^'abk ab Abkhazian ace Achinese ach Acoli ada Adangme aar aa Afar afh Afrihili afr af Afrikaans afa Afro-Asiatic (Other) aka Akan akk Akkadian alb/sqi sq Albanian ale Aleut alg Algonquian languages tut Altaic (Other) amh am Amharic apa Apache languages ara ar Arabic arc Aramaic arp Arapaho arn Araucanian arw Arawak arm/hye hy Armenian art Artificial (Other) asm as Assamese ath Athapascan languages map Austronesian (Other) ava Avaric ave Avestan awa Awadhi aym ay Aymara aze az Azerbaijani nah Aztec ban Balinese bat Baltic (Other) bal Baluchi bam Bambara bai Bamileke languages bad Banda bnt Bantu (Other) bas Basa bak ba Bashkir baq/eus eu Basque bej Beja bem Bemba ben bn Bengali ber Berber (Other) bho Bhojpuri bih bh Bihari bik Bikol bin Bini bis bi Bislama bra Braj bre be Breton bug Buginese bul bg Bulgarian bua Buriat bur/mya my Burmese bel be Byelorussian cad Caddo car Carib cat ca Catalan cau Caucasian (Other) ceb Cebuano cel Celtic (Other) cai Central American Indian (Other) chg Chagatai cha Chamorro che Chechen chr Cherokee chy Cheyenne chb Chibcha chi/zho zh Chinese chn Chinook jargon cho Choctaw chu Church Slavic chv Chuvash cop Coptic cor Cornish cos co Corsican cre Cree mus Creek crp Creoles and Pidgins (Other) cpe Creoles and Pidgins, English-based (Other) cpf Creoles and Pidgins, French-based (Other) cpp Creoles and Pidgins, Portuguese-based (Other) cus Cushitic (Other) hr Croatian ces/cze cs Czech dak Dakota dan da Danish del Delaware din Dinka div Divehi doi Dogri dra Dravidian (Other) dua Duala dut/nla nl Dutch dum Dutch, Middle (ca. 1050-1350) dyu Dyula dzo dz Dzongkha efi Efik egy Egyptian (Ancient) eka Ekajuk elx Elamite eng en English enm English, Middle (ca. 1100-1500) ang English, Old (ca. 450-1100) esk Eskimo (Other) epo eo Esperanto est et Estonian ewe Ewe ewo Ewondo fan Fang fat Fanti fao fo Faroese fij fj Fijian fin fi Finnish fiu Finno-Ugrian (Other) fon Fon fra/fre fr French frm French, Middle (ca. 1400-1600) fro French, Old (842- ca. 1400) fry fy Frisian ful Fulah gaa Ga gae/gdh Gaelic (Scots) glg gl Gallegan lug Ganda gay Gayo gez Geez geo/kat ka Georgian deu/ger de German gmh German, Middle High (ca. 1050-1500) goh German, Old High (ca. 750-1050) gem Germanic (Other) gil Gilbertese gon Gondi got Gothic grb Grebo grc Greek, Ancient (to 1453) ell/gre el Greek, Modern (1453-) kal kl Greenlandic grn gn Guarani guj gu Gujarati hai Haida hau ha Hausa haw Hawaiian heb he Hebrew her Herero hil Hiligaynon him Himachali hin hi Hindi hmo Hiri Motu hun hu Hungarian hup Hupa iba Iban ice/isl is Icelandic ibo Igbo ijo Ijo ilo Iloko inc Indic (Other) ine Indo-European (Other) ind id Indonesian ina ia Interlingua (International Auxiliary language Association) ine Interlingue iku iu Inuktitut ipk ik Inupiak ira Iranian (Other) gai/iri ga Irish sga Irish, Old (to 900) mga Irish, Middle (900 - 1200) iro Iroquoian languages ita it Italian jpn ja Japanese jav/jaw jv/jw Javanese jrb Judeo-Arabic jpr Judeo-Persian kab Kabyle kac Kachin kam Kamba kan kn Kannada kau Kanuri kaa Kara-Kalpak kar Karen kas ks Kashmiri kaw Kawi kaz kk Kazakh kha Khasi khm km Khmer khi Khoisan (Other) kho Khotanese kik Kikuyu kin rw Kinyarwanda kir ky Kirghiz kom Komi kon Kongo kok Konkani kor ko Korean kpe Kpelle kro Kru kua Kuanyama kum Kumyk kur ku Kurdish kru Kurukh kus Kusaie kut Kutenai lad Ladino lah Lahnda lam Lamba oci oc Langue d''Oc (post 1500) lao lo Lao lat la Latin lav lv Latvian ltz Letzeburgesch lez Lezghian lin ln Lingala lit lt Lithuanian loz Lozi lub Luba-Katanga lui Luiseno lun Lunda luo Luo (Kenya and Tanzania) mac/mak mk Macedonian mad Madurese mag Magahi mai Maithili mak Makasar mlg mg Malagasy may/msa ms Malay mal Malayalam mlt ml Maltese man Mandingo mni Manipuri mno Manobo languages max Manx mao/mri mi Maori mar mr Marathi chm Mari mah Marshall mwr Marwari mas Masai myn Mayan languages men Mende mic Micmac min Minangkabau mis Miscellaneous (Other) moh Mohawk mol mo Moldavian mkh Mon-Kmer (Other) lol Mongo mon mn Mongolian mos Mossi mul Multiple languages mun Munda languages nau na Nauru nav Navajo nde Ndebele, North nbl Ndebele, South ndo Ndongo nep ne Nepali new Newari nic Niger-Kordofanian (Other) ssa Nilo-Saharan (Other) niu Niuean non Norse, Old nai North American Indian (Other) nor no Norwegian nno Norwegian (Nynorsk) nub Nubian languages nym Nyamwezi nya Nyanja nyn Nyankole nyo Nyoro nzi Nzima oji Ojibwa ori or Oriya orm om Oromo osa Osage oss Ossetic oto Otomian languages pal Pahlavi pau Palauan pli Pali pam Pampanga pag Pangasinan pan pa Panjabi pap Papiamento paa Papuan-Australian (Other) fas/per fa Persian peo Persian, Old (ca 600 - 400 B.C.) phn Phoenician pol pl Polish pon Ponape por pt Portuguese pra Prakrit languages pro Provencal, Old (to 1500) pus ps Pushto que qu Quechua roh rm Rhaeto-Romance raj Rajasthani rar Rarotongan roa Romance (Other) ron/rum ro Romanian rom Romany run rn Rundi rus ru Russian sal Salishan languages sam Samaritan Aramaic smi Sami languages smo sm Samoan sad Sandawe sag sg Sango san sa Sanskrit srd Sardinian sco Scots sel Selkup sem Semitic (Other) sr Serbian scr sh Serbo-Croatian srr Serer shn Shan sna sn Shona sid Sidamo bla Siksika snd sd Sindhi sin si Singhalese sit Sino-Tibetan (Other) sio Siouan languages sla Slavic (Other) ssw ss Siswant slk/slo sk Slovak slv sl Slovenian sog Sogdian som so Somali son Songhai wen Sorbian languages nso Sotho, Northern sot st Sotho, Southern sai South American Indian (Other) esl/spa es Spanish suk Sukuma sux Sumerian sun su Sudanese sus Susu swa sw Swahili ssw Swazi sve/swe sv Swedish syr Syriac tgl tl Tagalog tah Tahitian tgk tg Tajik tmh Tamashek tam ta Tamil tat tt Tatar tel te Telugu ter Tereno tha th Thai bod/tib bo Tibetan tig Tigre tir ti Tigrinya tem Timne tiv Tivi tli Tlingit tog to Tonga (Nyasa) ton Tonga (Tonga Islands) tru Truk tsi Tsimshian tso ts Tsonga tsn tn Tswana tum Tumbuka tur tr Turkish ota Turkish, Ottoman (1500 - 1928) tuk tk Turkmen tyv Tuvinian twi tw Twi uga Ugaritic uig ug Uighur ukr uk Ukrainian umb Umbundu und Undetermined urd ur Urdu uzb uz Uzbek vai Vai ven Venda vie vi Vietnamese vol vo Volapük vot Votic wak Wakashan languages wal Walamo war Waray was Washo cym/wel cy Welsh wol wo Wolof xho xh Xhosa sah Yakut yao Yao yap Yap yid yi Yiddish yor yo Yoruba zap Zapotec zen Zenaga zha za Zhuang zul zu Zulu zun Zuni'! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:15'! readISOCountriesFrom: stream "ISOLanguageDefinition readISOCountriesFrom: ISOLanguageDefinition isoCountryString readStream " | countries line | countries := Dictionary new. [stream atEnd or: [(line := stream nextLine readStream) atEnd]] whileFalse: [ countries at: (line upTo: Character tab) put: line upToEnd]. ^countries! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/1/2004 18:07'! readISOLanguagesFrom: stream "ISOLanguageDefinition readISOLanguagesFrom: ISOLanguageDefinition isoLanguages readStream " | languages language code3 index line | languages := Dictionary new. [stream atEnd or: [(line := stream nextLine readStream) atEnd]] whileFalse: [ language := ISOLanguageDefinition new. code3 := line upTo: Character tab. (index := code3 indexOf: $/) > 0 ifTrue: [ language iso3: (code3 copyFrom: 1 to: index-1). language iso3Alternate: (code3 copyFrom: index+1 to: code3 size)] ifFalse: [language iso3: code3]. language iso2: (line upTo: Character tab); language: line upToEnd. languages at: language iso3 put: language]. ^languages! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:38'! borderInset self borderStyle: (BorderStyle inset width: 2).! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:41'! borderRaised self borderStyle: (BorderStyle raised width: 2).! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/12/2001 01:38'! borderNormal self borderStyle: (BorderStyle width: 2 color: Color transparent).! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/17/2001 21:17'! borderThick self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/15/2001 14:43'! buttonSetup self actWhen: #buttonUp. self cornerStyle: #rounded. self borderNormal. self on: #mouseEnter send: #borderRaised to: self. self on: #mouseLeave send: #borderNormal to: self. self on: #mouseLeaveDragging send: #borderNormal to: self. self on: #mouseDown send: #borderInset to: self. self on: #mouseUp send: #borderRaised to: self.! ! !IconicButton methodsFor: 'initialization' stamp: 'nk 9/1/2004 17:14'! initializeToShow: aMorph withLabel: aLabel andSend: aSelector to: aReceiver "Initialize the receiver to show the current appearance of aMorph on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the specified selector to the specified receiver" | aThumbnail | aThumbnail _ Thumbnail new. aThumbnail makeThumbnailFromForm: (aMorph imageFormDepth: 32). ^ self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: self color andSend: aSelector to: aReceiver ! ! !IconicButton methodsFor: 'initialization' stamp: 'nk 9/7/2004 11:43'! initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: aColor andSend: aSelector to: aReceiver "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver" | labeledItem nonTranslucent | nonTranslucent := aColor asNontranslucentColor. labeledItem _ AlignmentMorph newColumn. labeledItem color: nonTranslucent. labeledItem borderWidth: 0. labeledItem layoutInset: 4@0; cellPositioning: #center. labeledItem addMorph: aThumbnail. labeledItem addMorphBack: (Morph new extent: (4@4)) beTransparent. labeledItem addMorphBack: (TextMorph new backgroundColor: nonTranslucent; contentsAsIs: aLabel; beAllFont: Preferences standardEToysFont; centered). self beTransparent; labelGraphic: ((labeledItem imageForm: 32 backgroundColor: nonTranslucent forRectangle: labeledItem fullBounds) replaceColor: nonTranslucent withColor: Color transparent); borderWidth: 0; target: aReceiver; actionSelector: #launchPartVia:label:; arguments: {aSelector. aLabel}; actWhen: #buttonDown. self stationarySetup.! ! !IconicButton methodsFor: 'initialization' stamp: 'nk 8/6/2004 11:34'! initializeWithThumbnail: aThumbnail withLabel: aLabel andSend: aSelector to: aReceiver "Initialize the receiver to show aThumbnail on its face, giving it the label supplied and arranging for it, when the button goes down on it, to obtain a new morph by sending the supplied selector to the supplied receiver" ^self initializeWithThumbnail: aThumbnail withLabel: aLabel andColor: Color transparent andSend: aSelector to: aReceiver ! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/18/2001 21:22'! stationarySetup self actWhen: #startDrag. self cornerStyle: #rounded. self borderNormal. self on: #mouseEnter send: #borderThick to: self. self on: #mouseDown send: nil to: nil. self on: #mouseLeave send: #borderNormal to: self. self on: #mouseLeaveDragging send: #borderNormal to: self. self on: #mouseUp send: #borderThick to: self.! ! !IdentityBag commentStamp: '<historical>' prior: 0! Like a Bag, except that items are compared with #== instead of #= . See the comment of IdentitySet for more information. ! ]style[(88 11 23)f3,f3LIdentitySet Comment;,f3! !IdentityBag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'! contentsClass ^IdentityDictionary! ! !IdentityDictionary commentStamp: 'ls 06/15/02 22:35' prior: 0! Like a Dictionary, except that keys are compared with #== instead of #= . See the comment of IdentitySet for more information.! ]style[(94 11 22)f1,f1LIdentitySet Comment;,f1! !IdentityGlyphMap methodsFor: 'as yet unclassified' stamp: 'yo 2/13/2004 04:07'! at: index ^ index - 1. ! ! !IdentitySet commentStamp: 'sw 1/14/2003 22:35' prior: 0! The same as a Set, except that items are compared using #== instead of #=. Almost any class named IdentityFoo is the same as Foo except for the way items are compared. In Foo, #= is used, while in IdentityFoo, #== is used. That is, identity collections will treat items as the same only if they have the same identity. For example, note that copies of a string are equal: ('abc' copy) = ('abc' copy) but they are not identitcal: ('abc' copy) == ('abc' copy) A regular Set will only include equal objects once: | aSet | aSet := Set new. aSet add: 'abc' copy. aSet add: 'abc' copy. aSet An IdentitySet will include multiple equal objects if they are not identical: | aSet | aSet := IdentitySet new. aSet add: 'abc' copy. aSet add: 'abc' copy. aSet ! !IdentitySkipList methodsFor: 'element comparison' stamp: 'LC 6/18/2001 20:28'! is: element1 equalTo: element2 ^ element1 == element2! ! !IdentitySkipList commentStamp: '<historical>' prior: 0! Like a SkipList, except that elements are compared with #== instead of #= . See the comment of IdentitySet for more information. ! ]style[(96 11 23)f3,f3LIdentitySet Comment;,f3! !IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'! offset ^0@0! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'gh 10/22/2001 13:24'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates. Since I am the identity matrix no transformation is made." ^aRectangle ! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 9/4/2002 19:24'! defaultAction "No one has handled this error, but now give them a chance to decide how to debug it. If none handle this either then open debugger (see UnhandedError-defaultAction)" UnhandledError signalForException: self! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'ajh 2/1/2003 00:57'! isResumable ^ false! ! !ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:08'! borderStyle: newStyle | newExtent | newExtent _ 2 * newStyle width + image extent. bounds extent = newExtent ifFalse:[super extent: newExtent]. super borderStyle: newStyle.! ! !ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:11'! borderWidth: bw | newExtent | newExtent _ 2 * bw + image extent. bounds extent = newExtent ifFalse:[super extent: newExtent]. super borderWidth: bw! ! !ImageMorph methodsFor: 'accessing' stamp: 'aoy 2/17/2003 01:17'! image: anImage self changed. image := anImage depth = 1 ifTrue: [ColorForm mappingWhiteToTransparentFrom: anImage] ifFalse: [anImage]. super extent: image extent! ! !ImageMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 20:01'! isOpaque "Return true if the receiver is marked as being completely opaque" ^ self valueOfProperty: #isOpaque ifAbsent: [false]! ! !ImageMorph methodsFor: 'drawing' stamp: 'dgd 9/7/2004 17:24'! drawOn: aCanvas | style | (style _ self borderStyle) ifNotNil:[ style frameRectangle: bounds on: aCanvas. ]. self isOpaque ifTrue:[aCanvas drawImage: image at: self innerBounds origin] ifFalse:[aCanvas translucentImage: image at: self innerBounds origin]! ! !ImageMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:46'! opacityString ^ (self isOpaque ifTrue: ['<on>'] ifFalse: ['<off>']), 'opaque' translated! ! !ImageMorph methodsFor: 'parts bin' stamp: 'sw 6/28/2001 11:32'! initializeToStandAlone super initializeToStandAlone. self image: DefaultForm. ! ! !ImageMorph methodsFor: 'testing' stamp: 'tk 11/1/2001 12:43'! basicType "Answer a symbol representing the inherent type I hold" "Number String Boolean player collection sound color etc" ^ #Image! ! !ImageMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 4/20/2001 12:11'! drawPostscriptOn: aCanvas | top f2 c2 clrs | clrs _ image colorsUsed. (clrs includes: Color transparent) ifFalse: [^super drawPostscriptOn: aCanvas]. "no need for this, then" top _ aCanvas topLevelMorph. f2 _ Form extent: self extent depth: image depth. c2 _ f2 getCanvas. c2 fillColor: Color white. c2 translateBy: bounds origin negated clippingTo: f2 boundingBox during: [ :c | top fullDrawOn: c ]. aCanvas paintImage: f2 at: bounds origin ! ! !ImageMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/29/2004 11:04'! wantsRecolorHandle ^ image isNil not and: [image depth == 1]! ! !ImageMorph commentStamp: 'efc 3/7/2003 17:48' prior: 0! ImageMorph is a morph that displays a picture (Form). My extent is determined by the extent of my form. Use #image: to set my picture. Structure: instance var Type Description image Form The Form to use when drawing Code examples: ImageMorph new openInWorld; grabFromScreen (Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld Relationship to SketchMorph: ImageMorph should be favored over SketchMorph, a parallel, legacy class -- see the Swiki FAQ for details ( http://minnow.cc.gatech.edu/squeak/1372 ). ! ]style[(10 37 4 97 33 11 5 47 42 3 62 18 11 109 39 5)f1LImageMorph Hierarchy;,f1,f1LForm Comment;,f1,f1i,f1,f1LForm Comment;,f1,f1dImageMorph new openInWorld; grabFromScreen;;,f1,f1d(Form fromFileNamed: 'myGraphicsFileName') asMorph openInWorld;;,f1,f1LSketchMorph Comment;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/1372;,f1! !ImageMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:09'! initialize "ImageMorph initialize" | h p d | DefaultForm _ (Form extent: 80@40 depth: 16). h _ DefaultForm height // 2. 0 to: h - 1 do: [:i | p _ (i * 2)@i. d _ i asFloat / h asFloat. DefaultForm fill: (p corner: DefaultForm extent - p) fillColor: (Color r: d g: 0.5 b: 1.0 - d)]. self registerInFlapsRegistry.! ! !ImageMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:10'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ImageMorph authoringPrototype 'Picture' 'A non-editable picture of something') forFlapNamed: 'Supplies']! ! !ImageMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:36'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !ImageMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! descriptionForPartsBin ^ self partName: 'Image' categories: #('Graphics' 'Basic') documentation: 'A non-editable picture. If you use the Paint palette to make a picture, you can edit it afterwards.'! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'! close stream close! ! !ImageReadWriter methodsFor: 'private' stamp: 'sd 1/30/2004 15:18'! on: aStream (stream _ aStream) reset. stream binary. "Note that 'reset' makes a file be text. Must do this after."! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:59'! allTypicalFileExtensions "Answer a collection of file extensions (lowercase) which files that my subclasses can read might commonly have" "ImageReadWriter allTypicalFileExtensions" | extensions | extensions _ Set new. self allSubclassesDo: [ :cls | extensions addAll: cls typicalFileExtensions ]. ^extensions! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'sd 1/30/2004 15:18'! formFromStream: aBinaryStream "Answer a ColorForm stored on the given stream. closes the stream" | reader readerClass form | readerClass _ self withAllSubclasses detect: [:subclass | subclass understandsImageFormat: aBinaryStream] ifNone: [ aBinaryStream close. ^self error: 'image format not recognized']. reader _ readerClass new on: aBinaryStream reset. Cursor read showWhile: [ form _ reader nextImage. reader close]. ^ form ! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:55'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#()! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 17:33'! understandsImageFormat: aStream ^(self new on: aStream) understandsImageFormat! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'yo 11/11/2002 17:30'! copyFromRootsForExport: rootArray "When possible, use copySmartRootsExport:. This way may not copy a complete tree of objects. Add to roots: all of the methods pointed to from the outside by blocks." | newRoots list segSize symbolHolder | arrayOfRoots _ rootArray. Smalltalk forgetDoIts. "self halt." symbolHolder _ Symbol allInstances, MultiSymbol allInstances. "Hold onto Symbols with strong pointers, so they will be in outPointers" (newRoots _ self rootsIncludingPlayers) ifNotNil: [ arrayOfRoots _ newRoots]. "world, presenter, and all Player classes" "Creation of the segment happens here" self copyFromRoots: arrayOfRoots sizeHint: 0. segSize _ segment size. [(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize]. "with methods pointed at from outside" [(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize]. "with methods, blocks from outPointers" "classes of receivers of blocks" list _ self compactClassesArray. outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). "Zap sender of a homeContext. Can't send live stacks out." 1 to: outPointers size do: [:ii | (outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil]. (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]]. symbolHolder.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'yo 3/31/2003 12:09'! copySmartRootsExport: rootArray "Use SmartRefStream to find the object. Make them all roots. Create the segment in memory. Project should be in first five objects in rootArray." | newRoots list segSize symbolHolder dummy replacements naughtyBlocks goodToGo allClasses sizeHint proj | Smalltalk forgetDoIts. "self halt." symbolHolder _ Symbol allInstances, MultiSymbol allInstances. "Hold onto Symbols with strong pointers, so they will be in outPointers" dummy _ ReferenceStream on: (DummyStream on: nil). "Write to a fake Stream, not a file" "Collect all objects" dummy insideASegment: true. "So Uniclasses will be traced" dummy rootObject: rootArray. "inform him about the root" dummy nextPut: rootArray. (proj _dummy project) ifNotNil: [self dependentsSave: dummy]. allClasses _ SmartRefStream new uniClassInstVarsRefs: dummy. "catalog the extra objects in UniClass inst vars. Put into dummy" allClasses do: [:cls | dummy references at: cls class put: false. "put Player5 class in roots" dummy blockers removeKey: cls class ifAbsent: []]. "refs _ dummy references." arrayOfRoots _ self smartFillRoots: dummy. "guaranteed none repeat" self savePlayerReferences: dummy references. "for shared References table" replacements _ dummy blockers. dummy project "recompute it" ifNil: [self error: 'lost the project!!']. dummy project class == DiskProxy ifTrue: [self error: 'saving the wrong project']. dummy _ nil. "force GC?" naughtyBlocks _ arrayOfRoots select: [ :each | (each isKindOf: ContextPart) and: [each hasInstVarRef] ]. "since the caller switched ActiveWorld, put the real one back temporarily" naughtyBlocks isEmpty ifFalse: [ World becomeActiveDuring: [ goodToGo _ PopUpMenu confirm: 'Some block(s) which reference instance variables are included in this segment. These may fail when the segment is loaded if the class has been reshaped. What would you like to do?' trueChoice: 'keep going' falseChoice: 'stop and take a look'. goodToGo ifFalse: [ naughtyBlocks inspect. self error: 'Here are the bad blocks']. ]. ]. "Creation of the segment happens here" "try using one-quarter of memory min: four megs to publish (will get bumped later)" sizeHint _ (Smalltalk garbageCollect // 4 // 4) min: 1024*1024. self copyFromRoots: arrayOfRoots sizeHint: sizeHint areUnique: true. segSize _ segment size. [(newRoots _ self rootsIncludingBlockMethods) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods pointed at from outside" [(newRoots _ self rootsIncludingBlocks) == nil] whileFalse: [ arrayOfRoots _ newRoots. self copyFromRoots: arrayOfRoots sizeHint: segSize areUnique: true]. "with methods, blocks from outPointers" list _ self compactClassesArray. outPointers _ outPointers, ((list select: [:cls | cls ~~ nil]), (Array with: 1717 with: list)). 1 to: outPointers size do: [:ii | (outPointers at: ii) class == BlockContext ifTrue: [outPointers at: ii put: nil]. (outPointers at: ii) class == MethodContext ifTrue: [outPointers at: ii put: nil]. "substitute new object in outPointers" (replacements includesKey: (outPointers at: ii)) ifTrue: [ outPointers at: ii put: (replacements at: (outPointers at: ii))]]. proj ifNotNil: [self dependentsCancel: proj]. symbolHolder.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'sw 11/19/2002 14:40'! dependentsCancel: aProject "Erase the place we temporarily held the dependents of things in this project. So we don't carry them around forever." aProject projectParameters removeKey: #GlobalDependentsInProject ifAbsent: []! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:17'! dependentsRestore: aProject "Retrieve the list of dependents from the exporting system, hook them up, and erase the place we stored them." | dict | dict _ aProject projectParameterAt: #GlobalDependentsInProject. dict ifNil: [^ self]. dict associationsDo: [:assoc | assoc value do: [:dd | assoc key addDependent: dd]]. self dependentsCancel: aProject.! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'tk 10/21/2002 16:25'! dependentsSave: dummy "Object that have dependents are supposed to be instances of subclasses of Model. But, class Objects still provides 'Global Dependents', and some people still use them. When both the model and the dependent are in a project that is being saved, remember them, so we can hook them up when this project is loaded in." | dict proj list | proj _ dummy project. dict _ Dictionary new. DependentsFields associationsDo: [:assoc | (dummy references includesKey: assoc key) ifTrue: [ list _ assoc value select: [:dd | dummy references includesKey: dd]. list size > 0 ifTrue: [dict at: assoc key put: list]]]. dict size > 0 ifTrue: [ proj projectParameterAt: #GlobalDependentsInProject put: dict]. ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'tk 6/22/2001 15:40'! findStacks "Return an array of all the StackMorphs in this project." | guys stacks | guys _ StackMorph withAllSubclasses asIdentitySet. stacks _ OrderedCollection new. arrayOfRoots do: [:obj | (guys includes: obj class) ifTrue: [stacks add: obj]]. ^ stacks! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'gk 2/24/2004 23:53'! install "This operation retrieves the segment if necessary from file storage, installs it in memory, and replaces (using become:) all the root stubs with the reconstructed roots of the segment." | newRoots | state = #onFile ifTrue: [self readFromFile]. state = #onFileWithSymbols ifTrue: [self readFromFileWithSymbols. endMarker _ segment nextObject. "for enumeration of objects" endMarker == 0 ifTrue: [endMarker _ 'End' clone]]. (state = #active) | (state = #imported) ifFalse: [self errorWrongState]. newRoots _ self loadSegmentFrom: segment outPointers: outPointers. state = #imported ifTrue: ["just came in from exported file" arrayOfRoots _ newRoots] ifFalse: [ arrayOfRoots elementsForwardIdentityTo: newRoots]. state _ #inactive. Beeper beepPrimitive! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/1/2004 16:26'! smartFillRoots: dummy | refs known ours ww blockers | "Put all traced objects into my arrayOfRoots. Remove some that want to be in outPointers. Return blockers, an IdentityDictionary of objects to replace in outPointers." blockers _ dummy blockers. known _ (refs _ dummy references) size. refs fasterKeys do: [:obj | "copy keys to be OK with removing items" (obj class == Symbol) ifTrue: [refs removeKey: obj. known _ known-1]. (obj class == MultiSymbol) ifTrue: [refs removeKey: obj. known _ known-1]. (obj class == PasteUpMorph) ifTrue: [ obj isWorldMorph & (obj owner == nil) ifTrue: [ obj == dummy project world ifFalse: [ refs removeKey: obj. known _ known-1. blockers at: obj put: (StringMorph contents: 'The worldMorph of a different world')]]]. "Make a ProjectViewMorph here" "obj class == Project ifTrue: [Transcript show: obj; cr]." (blockers includesKey: obj) ifTrue: [ refs removeKey: obj ifAbsent: [known _ known+1]. known _ known-1]. ]. ours _ dummy project world. refs keysDo: [:obj | obj isMorph ifTrue: [ ww _ obj world. (ww == ours) | (ww == nil) ifFalse: [ refs removeKey: obj. known _ known-1. blockers at: obj put: (StringMorph contents: obj printString, ' from another world')]]]. "keep original roots on the front of the list" (dummy rootObject) do: [:rr | refs removeKey: rr ifAbsent: []]. ^ dummy rootObject, refs fasterKeys asArray. ! ! !ImageSegment methodsFor: 'read/write segment' stamp: 'tk 12/2/2004 12:41'! writeForExportWithSources: fName inDirectory: aDirectory changeSet: aChangeSetOrNil "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk. Append the source code of any classes in roots. Target system will quickly transfer the sources to its changes file." "Files out a changeSet first, so that a project can contain classes that are unique to the project." | fileStream temp tempFileName zipper allClassesInRoots classesToWriteEntirely methodsWithSource | state = #activeCopy ifFalse: [self error: 'wrong state']. (fName includes: $.) ifFalse: [ ^ self inform: 'Please use ''.pr'' or ''.extSeg'' at the end of the file name'.]. temp _ endMarker. endMarker _ nil. tempFileName _ aDirectory nextNameFor: 'SqProject' extension: 'temp'. zipper _ [ Preferences debugPrintSpaceLog ifTrue:[ fileStream _ aDirectory newFileNamed: (fName copyFrom: 1 to: (fName lastIndexOf: $.)), 'space'. self printSpaceAnalysisOn: fileStream. fileStream close]. ProgressNotification signal: '3:uncompressedSaveComplete'. (aDirectory oldFileNamed: tempFileName) compressFile. "makes xxx.gz" aDirectory rename: (tempFileName, FileDirectory dot, 'gz') toBe: fName. aDirectory deleteFileNamed: tempFileName ifAbsent: [] ]. fileStream _ aDirectory newFileNamed: tempFileName. fileStream fileOutChangeSet: aChangeSetOrNil andObject: self. "remember extra structures. Note class names." endMarker _ temp. "append sources" allClassesInRoots _ arrayOfRoots select: [:cls | cls isKindOf: Behavior]. classesToWriteEntirely _ allClassesInRoots select: [ :cls | cls theNonMetaClass isSystemDefined]. methodsWithSource _ OrderedCollection new. allClassesInRoots do: [ :cls | (classesToWriteEntirely includes: cls) ifFalse: [ cls selectorsAndMethodsDo: [ :sel :meth | meth sourcePointer = 0 ifFalse: [methodsWithSource add: {cls. sel. meth}]. ]. ]. ]. (classesToWriteEntirely isEmpty and: [methodsWithSource isEmpty]) ifTrue: [zipper value. ^ self]. fileStream reopen; setToEnd. fileStream nextPutAll: '\\!!ImageSegment new!!\\' withCRs. methodsWithSource do: [ :each | fileStream nextPut: $!!. "try to pacify ImageSegment>>scanFrom:" fileStream nextChunkPut: 'RenamedClassSourceReader formerClassName: ', each first name printString,' methodsFor: ', (each first organization categoryOfElement: each second) asString printString, ' stamp: ',(Utilities timeStampForMethod: each third) printString; cr. fileStream nextChunkPut: (each third getSourceFor: each second in: each first) asString. fileStream nextChunkPut: ' '; cr. ]. classesToWriteEntirely do: [:cls | cls isMeta ifFalse: [fileStream nextPutAll: (cls name, ' category: ''', cls category, '''.!!'); cr; cr]. cls organization putCommentOnFile: fileStream numbered: 0 moveSource: false forClass: cls. "does nothing if metaclass" cls organization categories do: [:heading | cls fileOutCategory: heading on: fileStream moveSource: false toFile: 0]]. "no class initialization -- it came in as a real object" fileStream close. zipper value. ! ! !ImageSegment methodsFor: 'testing' stamp: 'nk 2/22/2005 22:13'! findRogueRootsAllMorphs: rootArray "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1) assemble all objects should be in seg: morph tree, presenter, scripts, player classes, metaclasses. Put in a Set. 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." | inSeg testRoots scriptEditors pointIn wld xRoots | Smalltalk garbageCollect. inSeg := IdentitySet new: 200. arrayOfRoots := rootArray. (testRoots := self rootsIncludingPlayers) ifNil: [testRoots := rootArray]. testRoots do: [:obj | (obj isKindOf: Project) ifTrue: [inSeg add: obj. wld := obj world. inSeg add: wld presenter]. (obj isKindOf: Presenter) ifTrue: [inSeg add: obj]]. xRoots := wld ifNil: [testRoots] ifNotNil: [testRoots , (Array with: wld)]. xRoots do: [:obj | "root is a project" obj isMorph ifTrue: [obj allMorphs do: [:mm | inSeg add: mm. mm player ifNotNil: [inSeg add: mm player]]. obj isWorldMorph ifTrue: [inSeg add: obj presenter]]]. scriptEditors := IdentitySet new. inSeg do: [:obj | obj isPlayerLike ifTrue: [scriptEditors addAll: (obj class tileScriptNames collect: [:nn | obj scriptEditorFor: nn])]]. scriptEditors do: [:se | inSeg addAll: se allMorphs]. testRoots do: [:each | inSeg remove: each ifAbsent: []]. "want them to be pointed at from outside" pointIn := IdentitySet new: 400. inSeg do: [:ob | pointIn addAll: (PointerFinder pointersTo: ob except: inSeg)]. testRoots do: [:each | pointIn remove: each ifAbsent: []]. pointIn remove: inSeg array ifAbsent: []. pointIn remove: pointIn array ifAbsent: []. inSeg do: [:obj | obj isMorph ifTrue: [pointIn remove: (obj instVarAt: 3) ifAbsent: ["submorphs" ]. "associations in extension" pointIn remove: obj extension ifAbsent: []. obj extension ifNotNil: [obj extension otherProperties ifNotNil: [obj extension otherProperties associationsDo: [:ass | pointIn remove: ass ifAbsent: [] "*** and extension actorState" "*** and ActorState instantiatedUserScriptsDictionary ScriptInstantiations"]]]]. obj isPlayerLike ifTrue: [obj class scripts values do: [:us | pointIn remove: us ifAbsent: []]]]. "*** presenter playerlist" self halt: 'Examine local variables pointIn and inSeg'. ^pointIn! ! !ImageSegment methodsFor: 'testing' stamp: 'gm 2/22/2003 18:36'! findRogueRootsPrep "Part of the tool to track down unwanted pointers into the segment. Break all owner pointers in submorphs, scripts, and viewers in flaps." | wld players morphs scriptEditors | wld _ arrayOfRoots detect: [:obj | obj isMorph ifTrue: [obj isWorldMorph] ifFalse: [false]] ifNone: [nil]. wld ifNil: [wld _ arrayOfRoots detect: [:obj | obj isMorph] ifNone: [^ self error: 'can''t find a root morph']]. morphs _ IdentitySet new: 400. wld allMorphsAndBookPagesInto: morphs. players _ wld presenter allExtantPlayers. "just the cached list" players do: [:pp | scriptEditors _ pp class tileScriptNames collect: [:nn | pp scriptEditorFor: nn]. scriptEditors do: [:se | morphs addAll: se allMorphs]]. wld submorphs do: [:mm | "non showing flaps" (mm isKindOf: FlapTab) ifTrue: [ mm referent allMorphsAndBookPagesInto: morphs]]. morphs do: [:mm | "break the back pointers" mm isInMemory ifTrue: [ (mm respondsTo: #target) ifTrue: [ mm nearestOwnerThat: [:ow | ow == mm target ifTrue: [mm target: nil. true] ifFalse: [false]]]. (mm respondsTo: #arguments) ifTrue: [ mm arguments do: [:arg | arg ifNotNil: [ mm nearestOwnerThat: [:ow | ow == arg ifTrue: [mm arguments at: (mm arguments indexOf: arg) put: nil. true] ifFalse: [false]]]]]. mm eventHandler ifNotNil: ["recipients point back up" (morphs includesAllOf: (mm eventHandler allRecipients)) ifTrue: [ mm eventHandler: nil]]. "temporary, until using Model for PartsBin" (mm isMorphicModel) ifTrue: [ (mm model isMorphicModel) ifTrue: [ mm model breakDependents]]. (mm isTextMorph) ifTrue: [mm setContainer: nil]]]. (Smalltalk includesKey: #Owners) ifTrue: [Smalltalk at: #Owners put: nil]. "in case findOwnerMap: is commented out" "self findOwnerMap: morphs." morphs do: [:mm | "break the back pointers" mm isInMemory ifTrue: [mm privateOwner: nil]]. "more in extensions?" ! ! !ImageSegment methodsFor: 'testing' stamp: 'nk 2/22/2005 15:26'! findRogueRootsRefStrm: rootArray "This is a tool to track down unwanted pointers into the segment. If we don't deal with these pointers, the segment turns out much smaller than it should. These pointers keep a subtree of objects out of the segment. 1) assemble all objects that should be in the segment by using SmartReference Stream and a dummyReference Stream. Put in a Set. 2) Remove the roots from this list. Ask for senders of each. Of the senders, forget the ones that are in the segment already. Keep others. The list is now all the 'incorrect' pointers into the segment." | dummy goodInSeg inSeg ok pointIn | dummy := ReferenceStream on: (DummyStream on: nil). "Write to a fake Stream, not a file" rootArray do: [:root | dummy rootObject: root. "inform him about the root" dummy nextPut: root]. inSeg := dummy references keys. dummy := nil. Smalltalk garbageCollect. "dump refs dictionary" rootArray do: [:each | inSeg remove: each ifAbsent: []]. "want them to be pointed at from outside" pointIn := IdentitySet new: 500. goodInSeg := IdentitySet new: 2000. inSeg do: [:obj | ok := obj class isPointers. obj class == Color ifTrue: [ok := false]. obj class == TranslucentColor ifTrue: [ok := false]. obj class == Array ifTrue: [obj size = 0 ifTrue: [ok := false]]. "shared #() in submorphs of all Morphs" ok ifTrue: [goodInSeg add: obj]]. goodInSeg do: [:ob | pointIn addAll: (PointerFinder pointersTo: ob except: #())]. inSeg do: [:each | pointIn remove: each ifAbsent: []]. rootArray do: [:each | pointIn remove: each ifAbsent: []]. pointIn remove: inSeg array ifAbsent: []. pointIn remove: goodInSeg array ifAbsent: []. pointIn remove: pointIn array ifAbsent: []. self halt: 'Examine local variables pointIn and inSeg'. ^pointIn! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 12/6/2004 09:56'! comeFullyUpOnReload: smartRefStream "fix up the objects in the segment that changed size. An object in the segment is the wrong size for the modern version of the class. Construct a fake class that is the old size. Replace the modern class with the old one in outPointers. Load the segment. Traverse the instances, making new instances by copying fields, and running conversion messages. Keep the new instances. Bulk forward become the old to the new. Let go of the fake objects and classes. After the install (below), arrayOfRoots is filled in. Globalize new classes. Caller may want to do some special install on certain objects in arrayOfRoots. May want to write the segment out to disk in its new form." | mapFakeClassesToReal ccFixups receiverClasses rootsToUnhiberhate myProject existing | RecentlyRenamedClasses _ nil. "in case old data hanging around" mapFakeClassesToReal _ smartRefStream reshapedClassesIn: outPointers. "Dictionary of just the ones that change shape. Substitute them in outPointers." ccFixups _ self remapCompactClasses: mapFakeClassesToReal refStrm: smartRefStream. ccFixups ifFalse: [^ self error: 'A class in the file is not compatible']. endMarker _ segment nextObject. "for enumeration of objects" endMarker == 0 ifTrue: [endMarker _ 'End' clone]. arrayOfRoots _ self loadSegmentFrom: segment outPointers: outPointers. "Can't use install. Not ready for rehashSets" mapFakeClassesToReal isEmpty ifFalse: [ self reshapeClasses: mapFakeClassesToReal refStream: smartRefStream ]. "When a Project is stored, arrayOfRoots has all objects in the project, except those in outPointers" arrayOfRoots do: [:importedObject | (importedObject isKindOf: MultiString) ifTrue: [ importedObject mutateJISX0208StringToUnicode. importedObject class = MultiSymbol ifTrue: [ "self halt." MultiSymbol hasInternedALoadedSymbol: importedObject ifTrue: [:multiSymbol | multiSymbol == importedObject ifFalse: [ importedObject becomeForward: multiSymbol. ]. ]. ]. ]. (importedObject isKindOf: TTCFontSet) ifTrue: [ existing _ TTCFontSet familyName: importedObject familyName pointSize: importedObject pointSize. "supplies default" existing == importedObject ifFalse: [importedObject becomeForward: existing]. ]. ]. "Smalltalk garbageCollect. MultiSymbol rehash. These take time and are not urgent, so don't to them. In the normal case, no bad MultiSymbols will be found." receiverClasses _ self restoreEndianness. "rehash sets" smartRefStream checkFatalReshape: receiverClasses. "Classes in this segment." arrayOfRoots do: [:importedObject | importedObject class class == Metaclass ifTrue: [self declare: importedObject]]. arrayOfRoots do: [:importedObject | (importedObject isKindOf: CompiledMethod) ifTrue: [ importedObject sourcePointer > 0 ifTrue: [importedObject zapSourcePointer]]. (importedObject isKindOf: Project) ifTrue: [ myProject _ importedObject. importedObject ensureChangeSetNameUnique. Project addingProject: importedObject. importedObject restoreReferences. self dependentsRestore: importedObject. ScriptEditorMorph writingUniversalTiles: ((importedObject projectPreferenceAt: #universalTiles) ifNil: [false])]]. rootsToUnhiberhate _ arrayOfRoots select: [:importedObject | importedObject respondsTo: #unhibernate "ScriptEditors and ViewerFlapTabs" ]. myProject ifNotNil: [ myProject world setProperty: #thingsToUnhibernate toValue: rootsToUnhiberhate ]. mapFakeClassesToReal isEmpty ifFalse: [ mapFakeClassesToReal keys do: [:aFake | aFake indexIfCompact > 0 ifTrue: [aFake becomeUncompact]. aFake removeFromSystemUnlogged]. SystemOrganization removeEmptyCategories]. "^ self" ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 12/5/2001 14:47'! declareAndPossiblyRename: classThatIsARoot | existing catInstaller | "The class just arrived in this segment. How fit it into the Smalltalk dictionary? If it had an association, that was installed with associationDeclareAt:." catInstaller _ [ classThatIsARoot superclass name == #Player ifTrue: [classThatIsARoot category: Object categoryForUniclasses] ifFalse: [(classThatIsARoot superclass name beginsWith: 'WonderLandActor') ifTrue: [classThatIsARoot category: 'Balloon3D-UserObjects'] ifFalse: [classThatIsARoot category: 'Morphic-Imported']]. ]. classThatIsARoot superclass addSubclass: classThatIsARoot. (Smalltalk includesKey: classThatIsARoot name) ifFalse: [ "Class entry in Smalltalk not referred to in Segment, install anyway." catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing _ Smalltalk at: classThatIsARoot name. existing xxxClass == ImageSegmentRootStub ifTrue: [ "We are that segment!! Must ask it carefully!!" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. existing == false | (existing == nil) ifTrue: [ "association is in outPointers, just installed" catInstaller value. ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Conflict with existing global or copy of the class" (existing isKindOf: Class) ifTrue: [ classThatIsARoot isSystemDefined not ifTrue: [ "UniClass. give it a new name" classThatIsARoot setName: classThatIsARoot baseUniclass chooseUniqueClassName. catInstaller value. "must be after new name" ^ Smalltalk at: classThatIsARoot name put: classThatIsARoot]. "Take the incoming one" self inform: 'Using newly arrived version of ', classThatIsARoot name. classThatIsARoot superclass removeSubclass: classThatIsARoot. "just in case" (Smalltalk at: classThatIsARoot name) becomeForward: classThatIsARoot. catInstaller value. ^ classThatIsARoot superclass addSubclass: classThatIsARoot]. self error: 'Name already in use by a non-class: ', classThatIsARoot name. ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/24/2001 18:31'! endianness "Return which endian kind the incoming segment came from" ^ (segment first bitShift: -24) asCharacter == $d ifTrue: [#big] ifFalse: [#little]! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'ar 8/16/2001 13:26'! prepareToBeSaved "Prepare objects in outPointers to be written on the disk. They must be able to match up with existing objects in their new system. outPointers is already a copy. Classes are already converted to a DiskProxy. Associations in outPointers: 1) in Smalltalk. 2) in a classPool. 3) in a shared pool. 4) A pool dict pointed at directly" | left pool myClasses outIndexes key | myClasses _ Set new. arrayOfRoots do: [:aRoot | aRoot class class == Metaclass ifTrue: [myClasses add: aRoot]]. outIndexes _ IdentityDictionary new. outPointers withIndexDo: [:anOut :ind | anOut isVariableBinding ifTrue: [ (myClasses includes: anOut value) ifFalse: [outIndexes at: anOut put: ind] ifTrue: [(Smalltalk associationAt: anOut key ifAbsent: [3]) == anOut ifTrue: [outPointers at: ind put: (DiskProxy global: #Smalltalk selector: #associationDeclareAt: args: (Array with: anOut key))] ifFalse: [outIndexes at: anOut put: ind] ]]. (anOut isKindOf: Dictionary) ifTrue: ["Pools pointed at directly" (key _ Smalltalk keyAtIdentityValue: anOut ifAbsent: [nil]) ifNotNil: [ outPointers at: ind put: (DiskProxy global: key selector: #yourself args: #())]]. anOut isMorph ifTrue: [outPointers at: ind put: (StringMorph contents: anOut printString, ' that was not counted')] ]. left _ outIndexes keys asSet. left size > 0 ifTrue: ["Globals" (left copy) do: [:assoc | "stay stable while delete items" (Smalltalk associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ outPointers at: (outIndexes at: assoc) put: (DiskProxy global: #Smalltalk selector: #associationAt: args: (Array with: assoc key)). left remove: assoc]]]. left size > 0 ifTrue: ["Class variables" Smalltalk allClassesDo: [:cls | cls classPool size > 0 ifTrue: [ (left copy) do: [:assoc | "stay stable while delete items" (cls classPool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ outPointers at: (outIndexes at: assoc) put: (DiskProxy new global: cls name preSelector: #classPool selector: #associationAt: args: (Array with: assoc key)). left remove: assoc]]]]]. left size > 0 ifTrue: ["Pool variables" Smalltalk associationsDo: [:poolAssoc | poolAssoc value class == Dictionary ifTrue: ["a pool" pool _ poolAssoc value. (left copy) do: [:assoc | "stay stable while delete items" (pool associationAt: assoc key ifAbsent: [3]) == assoc ifTrue: [ outPointers at: (outIndexes at: assoc) put: (DiskProxy global: poolAssoc key selector: #associationAt: args: (Array with: assoc key)). left remove: assoc]]]]]. left size > 0 ifTrue: [ "If points to class in arrayOfRoots, must deal with it separately" "OK to have obsolete associations that just get moved to the new system" self inform: 'extra associations'. left inspect]. ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/24/2001 18:21'! restoreEndianness "Fix endianness (byte order) of any objects not already fixed. Do this by discovering classes that need a startUp message sent to each instance, and sending it. I have just been brought in and converted to live objects. Find all Sets and Dictionaries in the newly created objects and rehash them. Segment is near then end of memory, since is was newly brought in (and a new object created for it). Also, collect all classes of receivers of blocks which refer to instance variables. Return them. Caller will check if they have been reshaped." | object sets receiverClasses inSeg noStartUpNeeded startUps cls msg | object _ segment. sets _ OrderedCollection new. "have to collect them, because Dictionary makes a copy, and that winds up at the end of memory and gets rehashed and makes another one." receiverClasses _ IdentitySet new. noStartUpNeeded _ IdentitySet new. "classes that don't have a per-instance startUp message" startUps _ IdentityDictionary new. "class -> MessageSend of a startUp message" inSeg _ true. [object _ object nextObject. "all the way to the end of memory to catch remade objects" object == endMarker ifTrue: [inSeg _ false]. "off end" object isInMemory ifTrue: [ (object isKindOf: Set) ifTrue: [sets add: object]. (object isKindOf: ContextPart) ifTrue: [ (inSeg and: [object hasInstVarRef]) ifTrue: [ receiverClasses add: object receiver class]]. inSeg ifTrue: [ (noStartUpNeeded includes: object class) ifFalse: [ cls _ object class. (msg _ startUps at: cls ifAbsent: [nil]) ifNil: [ msg _ cls startUpFrom: self. "a Message, if we need to swap bytes this time" msg ifNil: [noStartUpNeeded add: cls] ifNotNil: [startUps at: cls put: msg]]. msg ifNotNil: [msg sentTo: object]]]]. object == 0] whileFalse. sets do: [:each | each rehash]. "our purpose" ^ receiverClasses "our secondary job" ! ! !ImageSegment methodsFor: 'fileIn/Out' stamp: 'tk 10/21/2002 14:40'! storeDataOn: aDataStream "Don't wrote the array of Roots. Also remember the structures of the classes of objects inside the segment." | tempRoots tempOutP list | state = #activeCopy ifFalse: [self error: 'wrong state']. "real state is activeCopy, but we changed it will be right when coming in" tempRoots _ arrayOfRoots. tempOutP _ outPointers. outPointers _ outPointers clone. self prepareToBeSaved. arrayOfRoots _ nil. state _ #imported. super storeDataOn: aDataStream. "record my inst vars" arrayOfRoots _ tempRoots. outPointers _ tempOutP. state _ #activeCopy. aDataStream references at: #AnImageSegment put: false. "the false is meaningless" "This key in refs is the flag that there is an ImageSegment in this file." "Find the receivers of blocks in the segment. Need to get the structure of their classes into structures. Put the receivers into references." (aDataStream byteStream isKindOf: DummyStream) ifTrue: [ list _ Set new. arrayOfRoots do: [:ea | (ea class == BlockContext) | (ea class == MethodContext) ifTrue: [ list add: ea receiver class ]]. aDataStream references at: #BlockReceiverClasses put: list]. ! ! !ImageSegment methodsFor: 'compact classes' stamp: 'ar 2/21/2001 19:26'! compactClassesArray | ccIndexes ind ccArray hdrBits | "A copy of the real compactClassesArray, but with only the classes actually used in the segment. Slow, but OK for export." ccIndexes _ Set new. ind _ 2. "skip version word, first object" "go past extra header words" (hdrBits _ (segment atPin: ind) bitAnd: 3) = 1 ifTrue: [ind _ ind+1]. hdrBits = 0 ifTrue: [ind _ ind+2]. [ccIndexes add: (self compactIndexAt: ind). "0 if has class field" ind _ self objectAfter: ind. ind > segment size] whileFalse. ccArray _ Smalltalk compactClassesArray clone. 1 to: ccArray size do: [:ii | "only the ones we use" (ccIndexes includes: ii) ifFalse: [ccArray at: ii put: nil]]. ^ ccArray! ! !ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 18:44'! classNameAt: index | ccIndex | ccIndex _ self compactIndexAt: index. ccIndex = 0 ifFalse:[^(Smalltalk compactClassesArray at: ccIndex) name]. ccIndex _ segment at: index-1. (ccIndex bitAnd: 16r80000000) = 0 ifTrue:[ "within segment; likely a user object" ^#UserObject]. ccIndex _ (ccIndex bitAnd: 16r7FFFFFFF) bitShift: -2. ^(outPointers at: ccIndex) name! ! !ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:19'! doSpaceAnalysis "Capture statistics about the IS and print the number of instances per class and space usage" | index sz word hdrBits cc instCount instSpace | state == #activeCopy ifFalse:[self errorWrongState]. instCount _ IdentityDictionary new. instSpace _ IdentityDictionary new. index _ 2. "skip version word, first object" "go past extra header words" hdrBits _ (segment at: index) bitAnd: 3. hdrBits = 1 ifTrue: [index _ index+1]. hdrBits = 0 ifTrue: [index _ index+2]. [index > segment size] whileFalse:[ hdrBits _ (word _ segment at: index) bitAnd: 3. hdrBits = 2 ifTrue:[sz _ word bitAnd: 16rFFFFFFFC]. hdrBits = 0 ifTrue:[sz _ ((segment at: index-2) bitAnd: 16rFFFFFFFC) + 8]. hdrBits = 1 ifTrue:[sz _ (word bitAnd: "SizeMask" 252) + 4]. hdrBits = 3 ifTrue:[sz _ word bitAnd: "SizeMask" 252]. hdrBits = 2 ifTrue:[cc _ #freeChunk] ifFalse:[cc _ self classNameAt: index]. instCount at: cc put: (instCount at: cc ifAbsent:[0]) + 1. instSpace at: cc put: (instSpace at: cc ifAbsent:[0]) + sz. index _ self objectAfter: index]. ^{instCount. instSpace}! ! !ImageSegment methodsFor: 'statistics' stamp: 'ar 2/21/2001 19:22'! printSpaceAnalysisOn: aStream "Capture statistics about the IS and print the number of instances per class and space usage" | instCount instSpace sorted sum1 sum2 | instCount _ self doSpaceAnalysis. instSpace _ instCount last. instCount _ instCount first. sorted _ SortedCollection sortBlock:[:a1 :a2| a1 value >= a2 value]. instSpace associationsDo:[:a| sorted add: a]. sorted do:[:assoc| aStream cr; nextPutAll: assoc key; tab. aStream print: (instCount at: assoc key); nextPutAll:' instances '. aStream print: assoc value; nextPutAll: ' bytes '. ]. sum1 _ instCount inject: 0 into:[:sum :n| sum + n]. sum2 _ instSpace inject: 0 into:[:sum :n| sum + n]. aStream cr; cr. aStream print: sum1; nextPutAll:' instances '. aStream print: sum2; nextPutAll: ' bytes '. ! ! !ImageSegment methodsFor: '*SMBase-export' stamp: 'gk 11/7/2003 00:21'! writeForExportOn: fileStream "Write the segment on the disk with all info needed to reconstruct it in a new image. For export. Out pointers are encoded as normal objects on the disk." | temp | state = #activeCopy ifFalse: [self error: 'wrong state']. temp _ endMarker. endMarker _ nil. fileStream fileOutClass: nil andObject: self. "remember extra structures. Note class names." endMarker _ temp. ! ! !ImageSegment commentStamp: 'tk 12/2/2004 12:33' prior: 0! I represent a segment of Squeak address space. I am created from an array of root objects. After storing, my segment contains a binary encoding of every object accessible from my roots but not otherwise accessible from anywhere else in the system. My segment contains outward pointers that are indices into my table of outPointers. The main use of ImageSegments is to store Projects. A dummy version of SmartRefStream traverses the Project. Everything it finds is classified as either an object that is owned by the project (only pointed to inside the project), or an object outside the project that is pointed to from inside the project. The objects that are completely owned by the project are compressed into pure binary form in an ImageSegment. The outside objects are put in the 'outPointers' array. The entire ImageSegment (binary part plus outPointers) is encoded in a SmartRefStream, and saved on the disk. (aProject exportSegmentWithChangeSet:fileName:directory:) calls (anImageSegment writeForExportWithSources:inDirectory:changeSet:). Note that every object inside the project is put into the segment's arrayOfRoots. This is because a dummy SmartRefStream to scan the project, in order to make intelligent decisions about what belongs in the project. See Project's class comment for what messages are sent to objects as they are unpacked in a new image. ---- Older Details ------ The primary kind of image segment is an Export Segment. It can be saved on a server and read into a completely different Squeak image. Old way to create one: (ImageSegment new copyFromRootsForExport: (Array with: Baz with: Baz class)) writeForExport: 'myFile.extSeg'. Old way to create one for a project: (Project named: 'Play With Me - 3') exportSegment. To read it into another image: Select 'myFile.extSeg' in a FileList, Menu 'load as project'. It will install its classes automatically. If you need to see the roots array, it is temporarily stored in (SmartRefStream scannedObject). Most of 'states' of an ImageSegment are not used to export a project, and have been abandoned. When a segment is written out onto a file, it goes in a folder called <image name>_segs. If your image is called "Squeak2.6.image", the folder "Squeak2.6_segs" must accompany the image whenever your move, copy, or rename it. Whenever a Class is in arrayOfRoots, its class (aClass class) must also be in the arrayOfRoots. There are two kinds of image segments. Normal image segments are a piece of a specific Squeak image, and can only be read back into that image. The image holds the array of outPointers that are necessary to turn the bits in the file into objects. To put out a normal segment that holds a Project (not the current project), execute (Project named: 'xxx') storeSegment. arrayOfRoots The objects that head the tree we will trace. segment The WordArray of raw bits of all objects in the tree. outPointers Oops of all objects outside the segment pointed to from inside. state (see below) segmentName Its basic name. Often the name of a Project. fileName The local name of the file. 'Foo-23.seg' endMarker An object located in memory somewhere after a segment that has just been brought in. To enumerate the objects in the segment, start at the segment and go to this object. userRootCnt number of roots submitted by caller. Extras are added in preparation for saving. state that an ImageSegment may exist in... #activeCopy (has been copied, with the intent to become active) arrayOfRoots, segment, and outPointers have been created by copyFromRoots:. The tree of objects has been encoded in the segment, but those objects are still present in the Squeak system. #active (segment is actively holding objects) The segment is now the only holder of tree of objects. Each of the original roots has been transmuted into an ImageSegmentRootStub that refers back to this image segment. The original objects in the segment will all be garbageCollected. #onFile The segment has been written out to a file and replaced by a file pointer. Only ImageSegmentRootStubs and the array of outPointers remains in the image. To get this far: (ImageSegment new copyFromRoots: (Array with: Baz with: Baz class)) writeToFile: 'myFile.seg'. #inactive The segment has been brought back into memory and turned back into objects. rootsArray is set, but the segment is invalid. #onFileWithSymbols The segment has been written out to a file, along with the text of all the symbols in the outPointers array, and replaced by a file pointer. This reduces the size of the outPointers array, and also allows the system to reclaim any symbols that are not referred to from elsewhere in the image. The specific format used is that of a literal array as follows: #(symbol1 symbol2 # symbol3 symbol4 'symbolWithSpaces' # symbol5). In this case, the original outPointers array was 8 long, but the compacted table of outPointers retains only two entries. These get inserted in place of the #'s in the array of symbols after it is read back in. Symbols with embedded spaces or other strange characters are written as strings, and converted back to symbols when read back in. The symbol # is never written out. NOTE: All IdentitySets or dictionaries must be rehashed when being read back from this format. The symbols are effectively internal. (No, not if read back into same image. If a different image, then use #imported. -tk) #imported The segment is on an external file or just read in from one. The segment and outPointers are meant to be read into a foreign image. In this form, the image segment can be read from a URL, and installed. A copy of the original array of root objects is constructed, with former outPointers bound to existing objects in the host system. (Any Class inside the segment MUST be in the arrayOfRoots. This is so its association can be inserted into Smalltalk. The class's metaclass must be in roots also. Methods that are in outPointers because blocks point at them, were found and added to the roots. All IdentitySets and dictionaries are rehashed when being read back from exported segments.) To discover why only some of the objects in a project are being written out, try this (***Destructive Test***). This breaks lots of backpointers in the target project, and puts up an array of suspicious objects, a list of the classes of the outPointers, and a debugger. "Close any transcripts in the target project" World currentHand objectToPaste ifNotNil: [ self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, World currentHand objectToPaste printString]. PV _ Project named: 'xxxx'. (IS _ ImageSegment new) findRogueRootsImSeg: (Array with: PV world presenter with: PV world). IS findOwnersOutPtrs. "Optionally: write a file with owner chains" "Quit and DO NOT save" When an export image segment is brought into an image, it is like an image starting up. Certain startUp messages need to be run. These are byte and word reversals for nonPointer data that comes from a machine of the opposite endianness. #startUpProc passes over all objects in the segment, and: The first time an instance of class X is encountered, (msg _ X startUpFrom: anImageSegment) is sent. If msg is nil, the usual case, it means that instances of X do not need special work. X is included in the IdentitySet, noStartUpNeeded. If msg is not nil, store it in the dictionary, startUps (aClass -> aMessage). When a later instance of X is encountered, if X is in noStartUpNeeded, do nothing. If X is in startUps, send the message to the instance. Typically this is a message like #swapShortObjects. Every class that implements #startUp, should see if it needs a parallel implementation of #startUpFrom:. ! !ImageSegment class methodsFor: 'testing' stamp: 'di 3/7/2001 17:07'! discoverActiveClasses "ImageSegment discoverActiveClasses" "Run this method, do a few things, maybe save and resume the image. This will leave unused classes with MDFaults. You MUST follow this soon by activeClasses, or by swapOutInactiveClasses." "NOTE: discoverActiveClasses uses Squeak's ability to detect and recover from faults due to a nil method dictionary. It staches the method dict in with the organization during the time when discovery is in progress (Gag me with a spoon). This is why the faults need to be cleared promptly before resuming normal work with the system. It is also important that classes *do not* refer directly to their method dictionary, but only via the accessor message." | ok | Smalltalk allClasses do: [:c | ok _ true. #(Array Object Class Message MethodDictionary) do: [:n | ((Smalltalk at: n) == c or: [(Smalltalk at: n) inheritsFrom: c]) ifTrue: [ok _ false]]. ok ifTrue: [c induceMDFault]]. " ImageSegment discoverActiveClasses. -- do something typical -- PopUpMenu notify: ImageSegment activeClasses size printString , ' classes were active out of ' , Smalltalk allClasses size printString. "! ! !ImageSegment class methodsFor: 'fileIn/Out' stamp: 'sd 9/30/2003 14:02'! folder | im | "Full path name of segments folder. Be sure to duplicate and rename the folder when you duplicate and rename an image. Is $_ legal in all file systems?" im _ SmalltalkImage current imageName. ^ (im copyFrom: 1 to: im size - 6 "'.image' size"), '_segs'! ! !ImageSegment class methodsFor: 'fileIn/Out' stamp: 'sd 11/16/2003 14:17'! startUp | choice | "Minimal thing to assure that a .segs folder is present" (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ (FileDirectory default includesKey: (FileDirectory localNameFor: self folder)) ifFalse: [ choice _ (PopUpMenu labels: 'Create folder\Quit without saving' withCRs) startUpWithCaption: 'The folder with segments for this image is missing.\' withCRs, self folder, '\If you have moved or renamed the image file,\' withCRs, 'please Quit and rename the segments folder in the same way'. choice = 1 ifTrue: [FileDirectory default createDirectory: self folder]. choice = 2 ifTrue: [SmalltalkImage current snapshot: false andQuit: true]]] ! ! !ImageSegmentRootStub methodsFor: 'fetch from disk' stamp: 'di 3/4/2001 22:45'! doesNotUnderstand: aMessage | segmentName | "Any normal message sent to this object is really intended for another object that is in a non-resident imageSegment. Reinstall the segment and resend the message." segmentName _ imageSegment segmentName. imageSegment install. LoggingFaults ifTrue: "Save the stack printout to show who caused the fault" [FaultLogs at: Time millisecondClockValue printString put: (String streamContents: [:strm | strm nextPutAll: segmentName; cr. strm print: self class; space; print: aMessage selector; cr. (thisContext sender stackOfSize: 30) do: [:item | strm print: item; cr]])]. "NOTE: The following should really be (aMessage sentTo: self) in order to recover properly from a fault in a super-send, however, the lookupClass might be bogus in this case, and it's almost unthinkable that the first fault would be a super send." ^ self perform: aMessage selector withArguments: aMessage arguments! ! !ImmAbstractPlatform methodsFor: 'all' stamp: 'yo 11/7/2002 17:43'! keyboardFocusForAMorph: aMorph "do nothing" ! ! !ImmWin32 methodsFor: 'all' stamp: 'yo 11/30/2003 16:06'! keyboardFocusForAMorph: aMorph | left top pos | aMorph ifNil: [^ self]. [ pos _ aMorph prefereredKeyboardPosition. left _ (pos x min: Display width max: 0) asInteger. top _ (pos y min: Display height max: 0) asInteger. self setCompositionWindowPositionX: left y: top ] on: Error do: [:ex |]. ! ! !ImmWin32 methodsFor: 'as yet unclassified' stamp: 'yo 11/7/2002 16:47'! setCompositionWindowPositionX: x y: y <primitive: 'primSetCompositionWindowPosition' module: 'ImmWin32Plugin'> ^ nil ! ! !ImmX11 methodsFor: 'as yet unclassified' stamp: 'yo 12/25/2003 21:29'! keyboardFocusForAMorph: aMorph | left bottom pos | aMorph ifNil: [^ self]. [ pos _ aMorph prefereredKeyboardPosition. left _ (pos x min: Display width max: 0) asInteger. bottom _ (pos y min: Display height max: 0) asInteger + (aMorph paragraph characterBlockForIndex: aMorph editor selectionInterval first) height. self setCompositionWindowPositionX: left y: bottom ] on: Error do: [:ex |]. ! ! !ImmX11 methodsFor: 'as yet unclassified' stamp: 'Tsutomu Hiroshima 11/8/2003 08:46'! setCompositionWindowPositionX: x y: y <primitive: 'primSetCompositionWindowPosition' module: 'ImmX11Plugin'> ^ nil ! ! !Imports methodsFor: 'initialize' stamp: 'sd 5/11/2003 18:17'! initialize imports := Dictionary new.! ! !Imports methodsFor: 'images' stamp: 'sd 5/11/2003 20:36'! images "returns all the imported images" ^ imports values ! ! !Imports methodsFor: 'images' stamp: 'nk 6/12/2004 12:49'! importImage: anImage named: aName imports at: (Utilities keyLike: aName satisfying: [:ea | (imports includesKey: ea) not]) put: anImage! ! !Imports methodsFor: 'images' stamp: 'yo 7/17/2003 00:17'! imports ^ imports ! ! !Imports methodsFor: 'images' stamp: 'sd 5/11/2003 22:26'! namesAndImagesDo: aBlock "iterate over all the names and image" ^ imports keysAndValuesDo: aBlock ! ! !Imports methodsFor: 'images' stamp: 'sd 5/11/2003 22:21'! viewImages "Open up a special Form inspector on the dictionary of graphical imports." "Imports default viewImages" | widgetClass | imports size isZero ifTrue: [^ self inform: 'The ImageImports repository is currently empty, so there is nothing to view at this time. You can use a file list to import graphics from external files into Imports, and once you have done that, you will find this command more interesting.']. widgetClass := self couldOpenInMorphic ifTrue: [GraphicalDictionaryMenu] ifFalse: [FormInspectView]. widgetClass openOn: imports withLabel: 'Graphical Imports' ! ! !Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:44'! importImageDirectory: directoryOrName | dir extensions forms | dir := directoryOrName isString ifFalse: [ directoryOrName ] ifTrue: [ FileDirectory default directoryNamed: directoryOrName ]. dir exists ifFalse: [self error: dir fullName , ' does not exist'. ^ #()]. extensions := (ImageReadWriter allTypicalFileExtensions add: 'form'; yourself) collect: [:ex | '.' , ex]. forms := OrderedCollection new. dir fileNames do: [:fileName | | fullName | (fileName endsWithAnyOf: extensions) ifTrue: [fullName := dir fullNameFor: fileName. (self importImageFromFileNamed: fullName) ifNotNilDo: [:form | forms add: form]]]. ^ forms! ! !Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:44'! importImageDirectoryWithSubdirectories: directoryOrName | dir forms | dir := directoryOrName isString ifFalse: [ directoryOrName ] ifTrue: [ FileDirectory default directoryNamed: directoryOrName ]. dir exists ifFalse: [self error: dir fullName , ' does not exist'. ^ #()]. forms := OrderedCollection new. dir withAllSubdirectoriesCollect: [ :subdir | forms addAll: (self importImageDirectory: dir) ]. ^ forms! ! !Imports methodsFor: 'icons' stamp: 'nk 6/12/2004 12:25'! importImageFromFileNamed: fullName | localName pathParts form imageName | FileDirectory splitName: fullName to: [:dirPath :lname | localName := lname. pathParts := dirPath findTokens: FileDirectory slash]. form := [Form fromFileNamed: fullName] on: Error do: [:ex | ex return: nil]. form ifNil: [^ nil]. imageName := FileDirectory baseNameFor: localName. [imports includesKey: imageName] whileTrue: [imageName := pathParts isEmpty ifTrue: [Utilities keyLike: imageName satisfying: [:ea | (imports includesKey: ea) not]] ifFalse: [pathParts removeLast , '-' , imageName]]. imports at: imageName put: form. ^ form! ! !Imports commentStamp: 'sd 5/11/2003 20:34' prior: 0! I represent imported resources such as images, sounds, and other kind of files. For now I only store images in a simple way. To access my default instance use: Imports default. However I'm not a strict singleton and clients may create several of me using new. ! !Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:38'! default "Answer my default instance, creating one if necessary." "Imports default" ^default ifNil: [ default _ self new ]! ! !Imports class methodsFor: 'instance creation' stamp: 'nk 7/12/2003 10:36'! default: anImports "Set my default instance. Returns the old value if any." | old | old _ default. default _ anImports. ^old! ! !InMidstOfFileinNotification methodsFor: 'as yet unclassified' stamp: 'RAA 5/28/2001 17:07'! defaultAction self resume: false! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:14'! isFirstItem ^owner submorphs first == self! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'nk 3/8/2004 09:15'! isSoleItem ^self isFirstItem and: [ owner submorphs size = 1 ]! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'bf 2/9/2004 10:55'! userString "Add leading tabs to my userString" ^ (String new: indentLevel withAll: Character tab), super userString ! ! !IndentingListItemMorph methodsFor: 'drag and drop' stamp: 'nk 6/12/2004 16:49'! acceptDroppingMorph: toDrop event: evt complexContents acceptDroppingObject: toDrop complexContents. toDrop delete. self highlightForDrop: false.! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:25'! drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle "If I am not the only item in my container, draw the line between: - my toggle (if any) or my left edge (if no toggle) - and my text left edge" | myBounds myCenter hLineY hLineLeft | self isSoleItem ifTrue: [ ^self ]. myBounds := self toggleBounds. myCenter := myBounds center. hLineY := myCenter y. hasToggle ifTrue: [hLineLeft := myBounds right - 3] ifFalse: [hLineLeft := myCenter x - 1]. "Draw line from toggle to text" aCanvas line: hLineLeft @ hLineY to: myBounds right + 0 @ hLineY width: 1 color: lineColor! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:43'! drawLinesOn: aCanvas lineColor: lineColor | hasToggle | hasToggle _ self hasToggle. "Draw line from toggle to text" self drawLineToggleToTextOn: aCanvas lineColor: lineColor hasToggle: hasToggle. "Draw the line from my toggle to the nextSibling's toggle" self nextSibling ifNotNil: [ self drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle ]. "If I have children and am expanded, draw a line to my first child" (self firstChild notNil and: [ self isExpanded ]) ifTrue: [ self drawLinesToFirstChildOn: aCanvas lineColor: lineColor]! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:44'! drawLinesToFirstChildOn: aCanvas lineColor: lineColor "Draw line from me to next sibling" | vLineX vLineTop vLineBottom childBounds childCenter | childBounds := self firstChild toggleBounds. childCenter := childBounds center. vLineX := childCenter x - 1. vLineTop := bounds bottom. self firstChild hasToggle ifTrue: [vLineBottom := childCenter y - 7] ifFalse: [vLineBottom := childCenter y]. aCanvas line: vLineX @ vLineTop to: vLineX @ vLineBottom width: 1 color: lineColor! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 3/8/2004 11:41'! drawLinesToNextSiblingOn: aCanvas lineColor: lineColor hasToggle: hasToggle | myBounds nextSibBounds vLineX myCenter vLineTop vLineBottom | myBounds := self toggleBounds. nextSibBounds := self nextSibling toggleBounds. myCenter := myBounds center. vLineX := myCenter x - 1. hasToggle ifTrue: [vLineTop := myCenter y + 5] ifFalse: [vLineTop := myCenter y]. self nextSibling hasToggle ifTrue: [vLineBottom := nextSibBounds top + 2 ] ifFalse: [vLineBottom := nextSibBounds center y ]. "Draw line from me to next sibling" aCanvas line: vLineX @ vLineTop to: vLineX @ vLineBottom width: 1 color: lineColor! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 7/10/2002 11:53'! drawOn: aCanvas | tRect sRect columnRect columnScanner columnData columnLeft colorToUse | tRect := self toggleRectangle. sRect := bounds withLeft: tRect right + 4. self drawToggleOn: aCanvas in: tRect. colorToUse _ complexContents preferredColor ifNil: [color]. (container columns isNil or: [(contents asString indexOf: Character tab) = 0]) ifTrue: [ aCanvas drawString: contents asString in: sRect font: self fontToUse color: colorToUse. ] ifFalse: [ columnLeft _ sRect left. columnScanner _ ReadStream on: contents asString. container columns do: [ :width | columnRect _ columnLeft @ sRect top extent: width @ sRect height. columnData _ columnScanner upTo: Character tab. columnData isEmpty ifFalse: [ aCanvas drawString: columnData in: columnRect font: self fontToUse color: colorToUse. ]. columnLeft _ columnRect right + 5. ]. ] ! ! !IndentingListItemMorph methodsFor: 'drawing' stamp: 'nk 2/19/2004 18:19'! drawToggleOn: aCanvas in: aRectangle | aForm centeringOffset | complexContents hasContents ifFalse: [^self]. aForm _ isExpanded ifTrue: [container expandedForm] ifFalse: [container notExpandedForm]. centeringOffset _ ((aRectangle height - aForm extent y) / 2.0) rounded. ^aCanvas paintImage: aForm at: (aRectangle topLeft translateBy: 0 @ centeringOffset). ! ! !IndentingListItemMorph methodsFor: 'initialization' stamp: 'nop 2/10/2001 15:06'! initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel container _ hostList. complexContents _ anObject. self initWithContents: anObject asString font: Preferences standardListFont emphasis: nil. indentLevel _ 0. isExpanded _ false. nextSibling _ firstChild _ nil. priorMorph ifNotNil: [ priorMorph nextSibling: self. ]. indentLevel _ newLevel. ! ! !IndentingListItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" indentLevel _ 0. isExpanded _ false! ! !IndentingListItemMorph methodsFor: 'mouse events' stamp: 'ar 3/17/2001 17:32'! inToggleArea: aPoint ^self toggleRectangle containsPoint: aPoint! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 2/19/2004 18:29'! hasToggle ^ complexContents hasContents! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 12/5/2002 15:16'! toggleBounds ^self toggleRectangle! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'nk 10/14/2003 10:36'! openPath: anArray | found | anArray isEmpty ifTrue: [^ container setSelectedMorph: nil]. found _ nil. self withSiblingsDo: [:each | found ifNil: [(each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [found _ each]]]. found ifNil: ["try again with no case sensitivity" self withSiblingsDo: [:each | found ifNil: [(each complexContents asString sameAs: anArray first) ifTrue: [found _ each]]]]. found ifNotNil: [found isExpanded ifFalse: [found toggleExpandedState. container adjustSubmorphPositions]. found changed. anArray size = 1 ifTrue: [^ container setSelectedMorph: found]. ^ found firstChild ifNil: [container setSelectedMorph: nil] ifNotNil: [found firstChild openPath: anArray allButFirst]]. ^ container setSelectedMorph: nil! ! !IndentingListItemMorph commentStamp: '<historical>' prior: 0! An IndentingListItemMorph is a StringMorph that draws itself with an optional toggle at its left, as part of the display of the SimpleHierarchicalListMorph. It will also display lines around the toggle if the #showLinesInHierarchyViews Preference is set. Instance variables: indentLevel <SmallInteger> the indent level, from 0 at the root and increasing by 1 at each level of the hierarchy. isExpanded <Boolean> true if this item is expanded (showing its children) complexContents <ListItemWrapper> an adapter wrapping my represented item that can answer its children, etc. firstChild <IndentingListItemMorph|nil> my first child, or nil if none container <SimpleHierarchicalListMorph> my container nextSibling <IndentingListItemMorph|nil> the next item in the linked list of siblings, or nil if none. Contributed by Bob Arning as part of the ObjectExplorer package. Don't blame him if it's not perfect. We wanted to get it out for people to play with.! !IndexTabs methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !IndexTabs methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.0 g: 0.6 b: 0.6! ! !IndexTabs methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:43'! initialize "Initialize the receiver. Make sure it is not open to drag and drop" super initialize. "" padding _ 10. verticalPadding _ 4. basicHeight _ 14. basicWidth _ 200. self enableDragNDrop: false! ! !IndexTabs methodsFor: 'layout' stamp: 'dgd 2/22/2003 13:25'! requiredWidth submorphs isEmpty ifTrue: [^self basicWidth]. ^(submorphs detectSum: [:m | m width]) + (submorphs size * padding)! ! !IndexTabs methodsFor: 'layout' stamp: 'dgd 2/22/2003 13:25'! widthImposedByOwner ((owner isNil or: [owner isWorldOrHandMorph]) or: [owner submorphs size < 2]) ifTrue: [^self basicWidth]. ^owner submorphs second width! ! !InfiniteForm methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'! asColor ^ patternForm dominantColor! ! !InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "This is the real display message, but it doesn't get used until the new display protocol is installed." | targetBox patternBox bb | (patternForm isForm) ifFalse: [^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm]. "Do it iteratively" targetBox _ aDisplayMedium boundingBox intersect: clipRectangle. patternBox _ patternForm boundingBox. bb _ BitBlt current destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0 extent: patternBox extent clipRect: clipRectangle. bb colorMap: (patternForm colormapIfNeededFor: aDisplayMedium). (targetBox left truncateTo: patternBox width) to: targetBox right - 1 by: patternBox width do: [:x | (targetBox top truncateTo: patternBox height) to: targetBox bottom - 1 by: patternBox height do: [:y | bb destOrigin: x@y; copyBits]]! ! !InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! displayOnPort: aPort at: offset | targetBox patternBox savedMap top left | self flag: #bob. "this *may* not get called at the moment. I have been trying to figure out the right way for this to work and am using #displayOnPort:offsetBy: as my current offering - Bob" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox _ aPort clipRect. patternBox _ patternForm boundingBox. savedMap _ aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form paint; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top _ (targetBox top truncateTo: patternBox height) "- (offset y \\ patternBox height)". left _ (targetBox left truncateTo: patternBox width) "- (offset x \\ patternBox width)". left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! !InfiniteForm methodsFor: 'displaying' stamp: 'nk 4/17/2004 19:48'! displayOnPort: aPort offsetBy: offset | targetBox patternBox savedMap top left | "this version tries to get the form aligned where the user wants it and not just aligned with the cliprect" (patternForm isForm) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aPort fill: aPort clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox _ aPort clipRect. patternBox _ patternForm boundingBox. savedMap _ aPort colorMap. aPort sourceForm: patternForm; fillColor: nil; combinationRule: Form paint; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededFor: aPort destForm). top _ (targetBox top truncateTo: patternBox height) + offset y. left _ (targetBox left truncateTo: patternBox width) + offset x. left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aPort destOrigin: x@y; copyBits]]. aPort colorMap: savedMap. ! ! !InfiniteForm methodsFor: 'displaying' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ Color transparent! ! !InflateStream methodsFor: 'initialize' stamp: 'ls 1/2/2001 11:44'! on: aCollectionOrStream aCollectionOrStream isStream ifTrue:[ aCollectionOrStream binary. sourceStream _ aCollectionOrStream. self getFirstBuffer] ifFalse:[source _ aCollectionOrStream]. ^self on: source from: 1 to: source size.! ! !InflateStream methodsFor: 'accessing' stamp: 'nk 3/7/2004 18:45'! next: anInteger "Answer the next anInteger elements of my collection. overriden for simplicity" | newArray | "try to do it the fast way" position + anInteger < readLimit ifTrue: [ newArray _ collection copyFrom: position + 1 to: position + anInteger. position _ position + anInteger. ^newArray ]. "oh, well..." newArray _ collection species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: (self next ifNil: [ ^newArray copyFrom: 1 to: index - 1]) ]. ^newArray! ! !InflateStream methodsFor: 'private' stamp: 'ar 2/29/2004 04:18'! pastEndRead "A client has attempted to read beyond the read limit. Check in what state we currently are and perform the appropriate action" | blockType bp oldLimit | state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible" "Check if we can move decoded data to front" self moveContentsToFront. "Check if we can fetch more source data" self moveSourceToFront. state = StateNewBlock ifTrue:[state _ self getNextBlock]. blockType _ state bitShift: -1. bp _ self bitPosition. oldLimit := readLimit. self perform: (BlockTypes at: blockType+1). "Note: if bit position hasn't advanced then nothing has been decoded." bp = self bitPosition ifTrue:[^self primitiveFailed]. "Update crc for the decoded contents" readLimit > oldLimit ifTrue:[crc _ self updateCrc: crc from: oldLimit+1 to: readLimit in: collection]. state = StateNoMoreData ifTrue:[self verifyCrc]. ^self next! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:04'! crcError: aString ^CRCError signal: aString! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 03:49'! updateCrc: oldCrc from: start to: stop in: aCollection "Answer an updated CRC for the range of bytes in aCollection. Subclasses can implement the appropriate means for the check sum they wish to use." ^oldCrc! ! !InflateStream methodsFor: 'crc' stamp: 'ar 2/29/2004 04:22'! verifyCrc "Verify the crc checksum in the input"! ! !InfoStringMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" stepTime _ 1000. block _ [Time now]! ! !InputSensor methodsFor: 'accessing' stamp: 'JMM 10/5/2001 12:54'! flushAllButDandDEvents! ! !InputSensor methodsFor: 'buttons' stamp: 'nk 7/12/2000 09:33'! buttons "Answer the result of primMouseButtons, but swap the mouse buttons if Preferences swapMouseButtons is set." ^ ButtonDecodeTable at: self primMouseButtons + 1! ! !InputSensor methodsFor: 'cursor' stamp: 'ar 2/14/2001 00:00'! peekPosition ^self cursorPoint! ! !InputSensor methodsFor: 'initialize' stamp: 'nk 4/12/2004 19:45'! shutDown InterruptWatcherProcess ifNotNil: [ InterruptWatcherProcess terminate. InterruptWatcherProcess _ nil ].! ! !InputSensor methodsFor: 'keyboard' stamp: 'yo 8/18/2003 23:36'! keyboard "Answer the next character from the keyboard." | firstCharacter secondCharactor stream multiCharacter converter | firstCharacter _ self characterForKeycode: self primKbdNext. secondCharactor _ self characterForKeycode: self primKbdPeek. secondCharactor isNil ifTrue: [^ firstCharacter]. converter _ TextConverter defaultSystemConverter. converter isNil ifTrue: [^ firstCharacter]. stream _ ReadStream on: (String with: firstCharacter with: secondCharactor). multiCharacter _ converter nextFromStream: stream. multiCharacter isOctetCharacter ifTrue: [^ multiCharacter]. self primKbdNext. ^ multiCharacter ! ! !InputSensor methodsFor: 'modifier keys' stamp: 'sw 5/23/2001 13:46'! macOptionKeyPressed "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific." Preferences macOptionKeyAllowed ifFalse: [self notifyWithLabel: 'Portability note: InputSensor>>macOptionKeyPressed is not portable. Please use InputSensor>>yellowButtonPressed instead!!']. ^ self primMouseButtons anyMask: 32! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! anyButtonPressed "Answer whether at least one mouse button is currently being pressed." ^ self primMouseButtons anyMask: 7 ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! blueButtonPressed "Answer whether only the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^ (self primMouseButtons bitAnd: 7) = 1 ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:24'! mouseButtons "Answer a number from 0 to 7 that encodes the state of the three mouse buttons in its lowest 3 bits." ^ self primMouseButtons bitAnd: 7 ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:02'! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed not ! ! !InputSensor methodsFor: 'mouse' stamp: 'ar 2/14/2001 00:02'! peekButtons ^self primMouseButtons! ! !InputSensor methodsFor: 'mouse' stamp: 'ar 2/8/2001 21:45'! peekMousePt ^self primMousePt! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:16'! redButtonPressed "Answer true if only the red mouse button is being pressed. This is the first mouse button, usually the left one." ^ (self primMouseButtons bitAnd: 7) = 4 ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! waitButton "Wait for the user to press any mouse button and then answer with the current location of the cursor." | delay | delay _ Delay forMilliseconds: 50. [self anyButtonPressed] whileFalse: [ delay wait ]. ^self cursorPoint ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:22'! waitButtonOrKeyboard "Wait for the user to press either any mouse button or any key. Answer the current cursor location or nil if a keypress occured." | delay | delay := Delay forMilliseconds: 50. [self anyButtonPressed] whileFalse: [delay wait. self keyboardPressed ifTrue: [^ nil]]. ^ self cursorPoint ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:25'! waitNoButton "Wait for the user to release any mouse button and then answer the current location of the cursor." | delay | delay _ Delay forMilliseconds: 50. [self anyButtonPressed] whileTrue: [ delay wait]. ^self cursorPoint ! ! !InputSensor methodsFor: 'mouse' stamp: 'nk 3/17/2004 07:05'! yellowButtonPressed "Answer whether only the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^ (self primMouseButtons bitAnd: 7) = 2 ! ! !InputSensor methodsFor: 'user interrupts' stamp: 'nk 4/12/2004 19:36'! eventTicklerProcess "Answer my event tickler process, if any" ^nil! ! !InputSensor methodsFor: 'user interrupts' stamp: 'nk 6/21/2004 10:41'! installInterruptWatcher "Initialize the interrupt watcher process. Terminate the old process if any." "Sensor installInterruptWatcher" InterruptWatcherProcess ifNotNil: [InterruptWatcherProcess terminate]. InterruptSemaphore _ Semaphore new. InterruptWatcherProcess _ [self userInterruptWatcher] forkAt: Processor lowIOPriority. self primInterruptSemaphore: InterruptSemaphore.! ! !InputSensor methodsFor: 'user interrupts' stamp: 'gk 2/23/2004 20:51'! userInterruptWatcher "Wait for user interrupts and open a notifier on the active process when one occurs." [true] whileTrue: [ InterruptSemaphore wait. Display deferUpdates: false. SoundService default shutDown. Smalltalk handleUserInterrupt] ! ! !InputSensor commentStamp: '<historical>' prior: 0! An InputSensor is an interface to the user input devices. There is at least one (sub)instance of InputSensor named Sensor in the system. Class variables: ButtonDecodeTable <ByteArray> - maps mouse buttons as reported by the VM to ones reported in the events. KeyDecodeTable <Dictionary<SmallInteger->SmallInteger>> - maps some keys and their modifiers to other keys (used for instance to map Ctrl-X to Alt-X) InterruptSemaphore <Semaphore> - signalled by the the VM and/or the event loop upon receiving an interrupt keystroke. InterruptWatcherProcess <Process> - waits on the InterruptSemaphore and then responds as appropriate.! !InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:14'! duplicateControlAndAltKeys: aBoolean "InputSensor duplicateControlAndAltKeys: true" Preferences setPreference: #duplicateControlAndAltKeys toValue: aBoolean. self installKeyDecodeTable ! ! !InputSensor class methodsFor: 'public' stamp: 'nk 7/11/2002 07:09'! installDuplicateKeyEntryFor: c | key | key _ c asInteger. "first do control->alt key" KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. "then alt->alt key" KeyDecodeTable at: { key . 8 } put: { key . 8 } ! ! !InputSensor class methodsFor: 'public' stamp: 'nk 2/11/2002 12:39'! installSwappedKeyEntryFor: c | key | key _ c asInteger. "first do control->alt key" KeyDecodeTable at: { key bitAnd: 16r9F . 2 } put: { key . 8 }. "then alt->control key" KeyDecodeTable at: { key . 8 } put: { key bitAnd: 16r9F . 2 }! ! !InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! keyDecodeTable ^KeyDecodeTable ifNil: [ self installKeyDecodeTable ]! ! !InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! swapControlAndAltKeys: aBoolean "InputSensor swapControlAndAltKeys: true" Preferences setPreference: #swapControlAndAltKeys toValue: aBoolean. self installKeyDecodeTable! ! !InputSensor class methodsFor: 'public' stamp: 'nk 2/10/2002 11:57'! swapMouseButtons: aBoolean "InputSensor swapMouseButtons: true" Preferences setPreference: #swapMouseButtons toValue: aBoolean. self installMouseDecodeTable.! ! !InputSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'! defaultCrossPlatformKeys "Answer a list of key letters that are used for common editing operations on different platforms." ^{ $c . $x . $v . $a . $s . $f . $g . $z } ! ! !InputSensor class methodsFor: 'class initialization' stamp: 'nk 7/11/2002 07:41'! installKeyDecodeTable "Create a decode table that swaps some keys if Preferences swapControlAndAltKeys is set" KeyDecodeTable _ Dictionary new. Preferences duplicateControlAndAltKeys ifTrue: [ self defaultCrossPlatformKeys do: [ :c | self installDuplicateKeyEntryFor: c ] ]. Preferences swapControlAndAltKeys ifTrue: [ self defaultCrossPlatformKeys do: [ :c | self installSwappedKeyEntryFor: c ] ]. ! ! !InputSensor class methodsFor: 'class initialization' stamp: 'nk 2/10/2002 11:55'! installMouseDecodeTable "Create a decode table that swaps the lowest-order 2 bits if Preferences swapMouseButtons is set" ButtonDecodeTable _ Preferences swapMouseButtons ifTrue: [ByteArray withAll: ((0 to: 255) collect: [:ea | ((ea bitAnd: 1) << 1 bitOr: (ea bitAnd: 2) >> 1) bitOr: (ea bitAnd: 16rFC) ])] ifFalse: [ByteArray withAll: (0 to: 255)]! ! !InputSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'! shutDown self default shutDown.! ! !InputSensor class methodsFor: 'system startup' stamp: 'nk 2/10/2002 11:57'! startUp self installMouseDecodeTable. self installKeyDecodeTable. self default startUp! ! !InputSensor class methodsFor: 'preference change notification' stamp: 'nk 7/11/2002 07:32'! duplicateControlAndAltKeysChanged "The Preference for duplicateControlAndAltKeys has changed." (Preferences valueOfFlag: #swapControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting swapControlAndAltKeys preference'. (Preferences preferenceAt: #swapControlAndAltKeys) rawValue: false. ]. self installKeyDecodeTable. ! ! !InputSensor class methodsFor: 'preference change notification' stamp: 'nk 7/11/2002 07:32'! swapControlAndAltKeysChanged "The Preference for swapControlAndAltKeys has changed." (Preferences valueOfFlag: #duplicateControlAndAltKeys ifAbsent: [false]) ifTrue: [ self inform: 'Resetting duplicateControlAndAltKeys preference'. (Preferences preferenceAt: #duplicateControlAndAltKeys) rawValue: false. ]. self installKeyDecodeTable. ! ! !InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:11'! bottomRightColor ^width = 1 ifTrue: [color twiceLighter] ifFalse: [color lighter]! ! !InsetBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'! colorsAtCorners | c c14 c23 | c _ self color. c14 _ c lighter. c23 _ c darker. ^Array with: c23 with: c14 with: c14 with: c23.! ! !InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#inset! ! !InsetBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:11'! topLeftColor ^width = 1 ifTrue: [color twiceDarker] ifFalse: [color darker]! ! !InsetBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph insetColor].! ! !InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0! see BorderedMorph! !Inspector methodsFor: 'accessing' stamp: 'ajh 7/7/2004 15:55'! context: ctxt "Set the context of inspection. Currently only used by my subclass ClosureEnvInspector. The inst var is here because we do primitiveChangeClassTo: between subclasses (see inspect:) between different subclasses, but also context could be used as a general concept in all inspectors" context _ ctxt! ! !Inspector methodsFor: 'accessing' stamp: 'hg 10/14/2001 16:20'! object: anObject "Set anObject to be the object being inspected by the receiver." | oldIndex | anObject == object ifTrue: [self update] ifFalse: [oldIndex _ selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0]. self inspect: anObject. oldIndex _ oldIndex min: self fieldList size. self changed: #inspectObject. oldIndex > 0 ifTrue: [self toggleIndex: oldIndex]. self changed: #fieldList. self changed: #contents]! ! !Inspector methodsFor: 'accessing' stamp: 'hmm 7/12/2001 20:35'! update "Reshow contents, assuming selected value may have changed." selectionIndex = 0 ifFalse: [self contentsIsString ifTrue: [contents _ self selection] ifFalse: [contents _ self selectionPrintString]. self changed: #contents. self changed: #selection. self changed: #selectionIndex]! ! !Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:45'! accept: aString | result | result := self doItReceiver class evaluatorClass new evaluate: (ReadStream on: aString) in: self doItContext to: self doItReceiver notifying: nil "fix this" ifFail: [self changed: #flash. ^ false]. result == #failedDoit ifTrue: [^ false]. self replaceSelectionValue: result. self changed: #contents. ^ true! ! !Inspector methodsFor: 'selecting' stamp: 'BG 11/7/2004 13:40'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." | basicIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object]. selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000]. (selectionIndex - 2) <= object class instSize ifTrue: [^ object instVarAt: selectionIndex - 2]. basicIndex _ selectionIndex - 2 - object class instSize. (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) ifTrue: [^ object basicAt: basicIndex] ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! ! !Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:03'! selectionPrintString | text | selectionUpdateTime := [text := [self selection printStringLimitedTo: 5000] on: Error do: [text := self printStringErrorText. text addAttribute: TextColor red from: 1 to: text size. text]] timeToRun. ^ text! ! !Inspector methodsFor: 'selecting' stamp: 'PHK 6/30/2004 11:50'! selectionUnmodifiable "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of 'self' (selectionIndex = 1) and 'all inst vars' (selectionIndex = 2) are unmodifiable" ^ selectionIndex <= 2! ! !Inspector methodsFor: 'menu commands' stamp: 'tk 10/18/2002 17:13'! addCollectionItemsTo: aMenu "If the current selection is an appropriate collection, add items to aMenu that cater to that kind of selection" | sel | ((((sel _ self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and: [sel size > 0]) ifTrue: [ aMenu addList: #( ('inspect element...' inspectElement))]. (sel isKindOf: MorphExtension) ifTrue: [ aMenu addList: #( ('inspect property...' inspectElement))].! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 3/20/2001 12:20'! browseFullProtocol "Open up a protocol-category browser on the value of the receiver's current selection. If in mvc, an old-style protocol browser is opened instead." | objectToRepresent | Smalltalk isMorphic ifFalse: [^ self spawnProtocol]. objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection]. InstanceBrowser new openOnObject: objectToRepresent inWorld: ActiveWorld showingSelector: nil! ! !Inspector methodsFor: 'menu commands' stamp: 'bf 7/15/2004 11:58'! chasePointers | selected saved | self selectionIndex == 0 ifTrue: [^ self changed: #flash]. selected _ self selection. saved _ self object. [self object: nil. (Smalltalk includesKey: #PointerFinder) ifTrue: [PointerFinder on: selected] ifFalse: [self inspectPointers]] ensure: [self object: saved]! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14'! classVarRefs "Request a browser of methods that store into a chosen instance variable" | aClass | (aClass _ self classOfSelection) ifNotNil: [self systemNavigation browseClassVarRefs: aClass]. ! ! !Inspector methodsFor: 'menu commands' stamp: 'PHK 6/30/2004 11:47'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1)." | sel aClass variableNames | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. aClass _ self object class. variableNames _ aClass allInstVarNames. (aClass isVariable and: [selectionIndex > (variableNames size + 2)]) ifTrue: [sel _ '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')'] ifFalse: [sel _ variableNames at: selectionIndex - 2]. (self selection isKindOf: Collection) ifTrue: [sel _ '(' , sel , ' at: 1)']. Clipboard clipboardText: sel asText! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14'! defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what currently selected. " | aClass sel | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass _ self object class) isVariable ifTrue: [^ self changed: #flash]. sel _ aClass allInstVarNames at: self selectionIndex - 2. self systemNavigation browseAllStoresInto: sel from: aClass! ! !Inspector methodsFor: 'menu commands' stamp: 'avi 2/18/2004 01:31'! explorePointers PointerExplorer new openExplorerFor: self selection! ! !Inspector methodsFor: 'menu commands' stamp: 'md 9/30/2004 16:42'! fieldListMenu: aMenu "Arm the supplied menu with items for the field-list of the receiver" Smalltalk isMorphic ifTrue: [aMenu addStayUpItemSpecial]. aMenu addList: #( ('inspect (i)' inspectSelection) ('explore (I)' exploreSelection)). self addCollectionItemsTo: aMenu. aMenu addList: #( - ('method refs to this inst var' referencesToSelection) ('methods storing into this inst var' defsOfSelection) ('objects pointing to this value' objectReferencesToSelection) ('chase pointers' chasePointers) ('explore pointers' explorePointers) - ('browse full (b)' browseMethodFull) ('browse class' browseClass) ('browse hierarchy (h)' classHierarchy) ('browse protocol (p)' browseFullProtocol) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' classVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('copy name (c)' copyName) ('basic inspect' inspectBasic)). Smalltalk isMorphic ifTrue: [aMenu addList: #( - ('tile for this value (t)' tearOffTile) ('viewer for this value (v)' viewerForValue))]. ^ aMenu " - ('alias for this value' aliasForValue) ('watcher for this slot' watcherForSlot)" ! ! !Inspector methodsFor: 'menu commands' stamp: 'yo 3/9/2004 11:04'! inspectElement | sel selSize countString count nameStrs | "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((sel _ self selection) isKindOf: SequenceableCollection) ifFalse: [(sel isKindOf: MorphExtension) ifTrue: [^ sel inspectElement]. ^ sel inspect]. (selSize _ sel size) == 1 ifTrue: [^ sel first inspect]. selSize <= 20 ifTrue: [nameStrs _ (1 to: selSize) asArray collect: [:ii | ii printString, ' ', (((sel at: ii) printStringLimitedTo: 25) replaceAll: Character cr with: Character space)]. count _ PopUpMenu withCaption: 'which element?' chooseFrom: nameStrs. count = 0 ifTrue: [^ self]. ^ (sel at: count) inspect]. countString _ FillInTheBlank request: 'Which element? (1 to ', selSize printString, ')' initialAnswer: '1'. countString isEmptyOrNil ifTrue: [^ self]. count _ Integer readFrom: (ReadStream on: countString). (count > 0 and: [count <= selSize]) ifTrue: [(sel at: count) inspect] ifFalse: [Beeper beep]! ! !Inspector methodsFor: 'menu commands' stamp: 'apb 7/14/2004 13:16'! inspectSelection "Create and schedule an Inspector on the receiver's model's currently selected object." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. self selection inspect. ^ self selection! ! !Inspector methodsFor: 'menu commands' stamp: 'rhi 5/27/2004 17:09'! inspectorKey: aChar from: view "Respond to a Command key issued while the cursor is over my field list" aChar == $i ifTrue: [^ self selection inspect]. aChar == $I ifTrue: [^ self selection explore]. aChar == $b ifTrue: [^ self browseMethodFull]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $c ifTrue: [^ self copyName]. aChar == $p ifTrue: [^ self browseFullProtocol]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $t ifTrue: [^ self tearOffTile]. aChar == $v ifTrue: [^ self viewerForValue]. ^ self arrowKey: aChar from: view! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 4/16/2003 11:41'! objectReferencesToSelection "Open a list inspector on all the objects that point to the value of the selected instance variable, if any. " self selectionIndex == 0 ifTrue: [^ self changed: #flash]. self systemNavigation browseAllObjectReferencesTo: self selection except: (Array with: self object) ifNone: [:obj | self changed: #flash]. ! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 4/15/2003 16:14'! referencesToSelection "Open a browser on all references to the selected instance variable, if that's what currently selected. 1/25/96 sw" | aClass sel | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass _ self object class) isVariable ifTrue: [^ self changed: #flash]. sel _ aClass allInstVarNames at: self selectionIndex - 2. self systemNavigation browseAllAccessesTo: sel from: aClass! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 12/11/2000 15:52'! spawnFullProtocol "Spawn a window showing full protocol for the receiver's selection" | objectToRepresent | objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection]. ProtocolBrowser openFullProtocolForClass: objectToRepresent class! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 12/11/2000 15:52'! spawnProtocol "Spawn a protocol on browser on the receiver's selection" | objectToRepresent | objectToRepresent _ self selectionIndex == 0 ifTrue: [object] ifFalse: [self selection]. ProtocolBrowser openSubProtocolForClass: objectToRepresent class! ! !Inspector methodsFor: 'initialize-release' stamp: 'apb 7/14/2004 14:45'! initialize selectionIndex _ 0. super initialize! ! !Inspector methodsFor: 'initialize-release' stamp: 'apb 7/26/2004 16:44'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection. Normally the receiver will be of the correct class (as defined by anObject inspectorClass), because it will have just been created by sedning inspect to anObject. However, the debugger uses two embedded inspectors, which are re-targetted on the current receiver each time the stack frame changes. The left-hand inspector in the debugger has its class changed by the code here. Care should be taken if this method is overridden to ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that the class of these embedded inspectors are changed back." | c | c _ anObject inspectorClass. (self class ~= c and: [self class format = c format]) ifTrue: [ self primitiveChangeClassTo: c basicNew]. "Set 'object' before sending the initialize message, because some implementations of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." object _ anObject. self initialize! ! !Inspector methodsFor: 'private' stamp: 'apb 8/20/2004 22:05'! printStringErrorText | nm | nm _ self selectionIndex < 3 ifTrue: ['self'] ifFalse: [self selectedSlotName]. ^ ('<error in printString: evaluate "' , nm , ' printString" to debug>') asText.! ! !Inspector methodsFor: 'stepping' stamp: 'apb 7/14/2004 14:28'! stepAt: millisecondClockValue in: aWindow | newText | (Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds" ifTrue: [self updateListsAndCodeIn: aWindow. timeOfLastListUpdate _ millisecondClockValue]. newText _ self contentsIsString ifTrue: [self selection] ifFalse: ["keep it short to reduce time to compute it" self selectionPrintString ]. newText = contents ifFalse: [contents _ newText. self changed: #contents]! ! !Inspector class methodsFor: 'instance creation' stamp: 'PHK 7/22/2004 17:04'! inspect: anObject "Answer an instance of me to provide an inspector for anObject." "We call basicNew to avoid a premature initialization; the instance method inspect: anObject will do a self initialize." ^self basicNew inspect: anObject! ! !Inspector class methodsFor: 'instance creation' stamp: 'apb 7/14/2004 12:54'! openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass "Note: for now, this always adds an eval pane, and ignores the valueViewClass" ^ (self openAsMorphOn: anObject withLabel: label) openInWorld! ! !Inspector class methodsFor: 'instance creation' stamp: 'PHK 6/30/2004 10:48'! openAsMorphOn: anObject withLabel: aLabel "(Inspector openAsMorphOn: SystemOrganization) openInMVC" | window inspector | inspector _ self inspect: anObject. window _ (SystemWindow labelled: aLabel) model: inspector. window addMorph: ( PluggableListMorph new doubleClickSelector: #inspectSelection; on: inspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) frame: (0@0 corner: self horizontalDividerProportion @ self verticalDividerProportion). window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (self horizontalDividerProportion @0 corner: 1@self verticalDividerProportion). window addMorph: ((PluggableTextMorph on: inspector text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) askBeforeDiscardingEdits: false) frame: (0@self verticalDividerProportion corner: 1@1). window setUpdatablePanesFrom: #(fieldList). window position: 16@0. "Room for scroll bar." ^ window! ! !Inspector class methodsFor: 'instance creation' stamp: 'PHK 6/30/2004 10:51'! openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass | topView inspector listView valueView evalView | inspector _ self inspect: anObject. topView _ StandardSystemView new model: inspector. topView borderWidth: 1. listView _ PluggableListView on: inspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:. listView window: (0 @ 0 extent: 40 @ 40). topView addSubView: listView. valueView _ valueViewClass new. "PluggableTextView or PluggableFormView" (valueView respondsTo: #getText) ifTrue: [ valueView on: inspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:]. (valueViewClass inheritsFrom: FormView) ifTrue: [ valueView model: inspector]. valueView window: (0 @ 0 extent: 75 @ 40). topView addSubView: valueView toRightOf: listView. withEval ifTrue: [evalView _ PluggableTextView new on: inspector text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. evalView window: (0 @ 0 extent: 115 @ 20). evalView askBeforeDiscardingEdits: false. topView addSubView: evalView below: listView]. topView label: label. topView minimumSize: 180 @ 120. topView setUpdatablePanesFrom: #(fieldList). topView controller open! ! !InspectorBrowser methodsFor: 'initialize-release' stamp: 'apb 7/26/2004 17:34'! initialize super initialize. fieldList _ nil. msgListIndex _ 0. self changed: #msgText ! ! !InspectorBrowser methodsFor: 'initialize-release' stamp: 'apb 7/26/2004 17:34'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection. Overriden so that my class is not changed to 'anObject inspectorClass'." object _ anObject. self initialize ! ! !InspectorBrowser methodsFor: 'messages' stamp: 'apb 7/14/2004 13:50'! msgList msgList ifNotNil: [^ msgList]. ^ (msgList _ object class selectors asSortedArray)! ! !InspectorBrowser methodsFor: 'messages' stamp: 'apb 7/14/2004 13:57'! msgListMenu: aMenu ^ aMenu labels: 'Not yet implemented' lines: #(0) selections: #(flash)! ! !InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'! interpretNextInstructionUsing: aScanner bingo _ false. aScanner interpretNextInstructionFor: self. ^bingo! ! !InstVarRefLocator commentStamp: 'md 4/8/2003 12:50' prior: 0! My job is to scan bytecodes for instance variable references. BlockContext allInstances collect: [ :x | {x. x hasInstVarRef} ].! !InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'! example1 | ff| (1 < 2) ifTrue: [tt ifNotNil: [ff _ 'hallo']]. ^ ff.! ! !InstVarRefLocatorTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:31'! example2 | ff| ff := 1. (1 < 2) ifTrue: [ff ifNotNil: [ff _ 'hallo']]. ^ ff.! ! !InstVarRefLocatorTest methodsFor: 'private' stamp: 'md 4/8/2003 12:39'! hasInstVarRef: aMethod "Answer whether the receiver references an instance variable." | scanner end printer | scanner _ InstructionStream on: aMethod. printer _ InstVarRefLocator new. end _ scanner method endPC. [scanner pc <= end] whileTrue: [ (printer interpretNextInstructionUsing: scanner) ifTrue: [^true]. ]. ^false! ! !InstVarRefLocatorTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:42'! testExample1 | method | method := self class compiledMethodAt: #example1. self assert: (self hasInstVarRef: method).! ! !InstVarRefLocatorTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:42'! testExample2 | method | method := self class compiledMethodAt: #example2. self deny: (self hasInstVarRef: method).! ! !InstVarRefLocatorTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:35'! testInstructions | scanner end printer methods | methods := Object methodDict values. methods do: [:method | scanner _ InstructionStream on: method. printer _ InstVarRefLocator new. end _ scanner method endPC. [scanner pc <= end] whileTrue: [ self shouldnt: [printer interpretNextInstructionUsing: scanner] raise: Error. ]. ].! ! !InstVarRefLocatorTest commentStamp: '<historical>' prior: 0! This is the unit test for the class InstVarRefLocator. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !InstanceBrowser methodsFor: 'initialization' stamp: 'sw 5/25/2001 10:47'! desiredWindowLabelHeightIn: aSystemWindow "Answer the desired window label height. To be exploited in due course" self flag: #deferred. "For tweaking appearance in due course" ^ nil! ! !InstanceBrowser methodsFor: 'initialization' stamp: 'sw 3/20/2001 12:16'! openOnObject: anObject inWorld: aWorld showingSelector: aSelector "Create and open a SystemWindow to house the receiver, showing the categories pane." objectViewed _ anObject. self openOnClass: anObject class inWorld: aWorld showingSelector: aSelector! ! !InstanceBrowser methodsFor: 'initialization' stamp: 'sw 8/3/2001 18:38'! windowWithLabel: aLabel "Answer a SystemWindow associated with the receiver, with appropriate border characteristics" | window | "The first branch below provides a pretty nice effect -- a large draggable border when active, a minimal border when not -- but the problem is that we often rely on the title bar to convey useful information. For the moment, whether the titled or nontitled variant is used is governed by the hard-coded preference named 'suppressWindowTitlesInInstanceBrowsers'" Preferences suppressWindowTitlesInInstanceBrowsers ifTrue: [(window _ SystemWindow newWithoutLabel) model: self. window setProperty: #borderWidthWhenActive toValue: 8. window setProperty: #borderWidthWhenInactive toValue: 1. window borderWidth: 8] ifFalse: [(window _ SystemWindow labelled: aLabel) model: self]. ^ window ! ! !InstanceBrowser methodsFor: 'menu commands' stamp: 'sw 3/20/2001 13:20'! inspectViewee "Open an Inspector on the object I view" objectViewed inspect! ! !InstanceBrowser methodsFor: 'menu commands' stamp: 'sw 11/21/2001 14:36'! offerMenu "Offer a menu to the user, in response to the hitting of the menu button on the tool pane" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'Messages of ', objectViewed nameForViewer. aMenu addStayUpItem. aMenu addList: #( ('vocabulary...' chooseVocabulary) ('what to show...' offerWhatToShowMenu) - ('inst var refs (here)' setLocalInstVarRefs) ('inst var defs (here)' setLocalInstVarDefs) ('class var refs (here)' setLocalClassVarRefs) - ('navigate to a sender...' navigateToASender) ('recent...' navigateToRecentMethod) ('show methods in current change set' showMethodsInCurrentChangeSet) ('show methods with initials...' showMethodsWithInitials) - "('toggle search pane' toggleSearch)" - - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('versions (v)' browseVersions) ('inheritance (i)' methodHierarchy) - ('inst var refs' browseInstVarRefs) ('inst var defs' browseInstVarDefs) ('class var refs' browseClassVarRefs) - ('viewer on me' viewViewee) ('inspector on me' inspectViewee) - ('more...' shiftedYellowButtonActivity)). aMenu popUpInWorld: ActiveWorld! ! !InstanceBrowser methodsFor: 'menu commands' stamp: 'sw 3/20/2001 13:19'! viewViewee "Open a viewer on the object I view" objectViewed beViewed! ! !InstanceBrowser methodsFor: 'target-object access' stamp: 'sw 3/20/2001 12:10'! targetObject "Answer the object to which this tool is bound" ^ objectViewed! ! !InstanceBrowser methodsFor: 'window title' stamp: 'sw 3/20/2001 12:18'! startingWindowTitle "Answer the initial window title to apply" ^ 'Vocabulary of ', objectViewed nameForViewer! ! !InstanceBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:31'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Instance Browser' brightColor: #(0.806 1.0 1.0) pastelColor: #(0.925 1.000 1.0) helpMessage: 'A tool for browsing the full protocol of an instance.'! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! blockReturnTop "Return Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! doDup "Duplicate Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! doPop "Remove Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset "Unconditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset if: condition "Conditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! methodReturnConstant: value "Return Constant bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! methodReturnReceiver "Return Self bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! methodReturnTop "Return Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoReceiverVariable: offset "Remove Top Of Stack And Store Into Instance Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushConstant: value "Push Constant, value, on Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushLiteralVariable: anAssociation "Push Contents Of anAssociation On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushReceiver "Push Active Context's Receiver on Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:03'! pushReceiverVariable: offset "Push Contents Of the Receiver's Instance Variable Whose Index is the argument, offset, On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! pushTemporaryVariable: offset "Push Contents Of Temporary Variable Whose Index Is the argument, offset, On Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! send: selector super: supered numArgs: numberArguments "Send Message With Selector, selector, bytecode. The argument, supered, indicates whether the receiver of the message is specified with 'super' in the source method. The arguments of the message are found in the top numArguments locations on the stack and the receiver just below them." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoLiteralVariable: anAssociation "Store Top Of Stack Into Literal Variable Of Method bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoReceiverVariable: offset "Store Top Of Stack Into Instance Variable Of Method bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:04'! storeIntoTemporaryVariable: offset "Store Top Of Stack Into Temporary Variable Of Method bytecode." ! ! !InstructionClient commentStamp: 'md 4/8/2003 12:50' prior: 0! My job is to make it easier to implement clients for InstructionStream. See InstVarRefLocator as an example. ! !InstructionClientTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:07'! testInstructions "just interpret all of methods of Object" | methods client scanner| methods := Object methodDict values. client := InstructionClient new. methods do: [:method | scanner := (InstructionStream on: method). [scanner pc <= method endPC] whileTrue: [ self shouldnt: [scanner interpretNextInstructionFor: client] raise: Error. ]. ]. ! ! !InstructionClientTest commentStamp: '<historical>' prior: 0! This is the unit test for the class InstructionClient. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !InstructionPrinter methodsFor: 'accessing' stamp: 'ajh 6/27/2003 22:25'! indent ^ indent ifNil: [0]! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'! method ^method.! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'! method: aMethod method := aMethod.! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'ajh 2/9/2003 14:16'! indent: numTabs indent _ numTabs! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:19'! printInstructionsOn: aStream "Append to the stream, aStream, a description of each bytecode in the instruction stream." | end | stream _ aStream. scanner _ InstructionStream on: method. end _ method endPC. oldPC _ scanner pc. [scanner pc <= end] whileTrue: [scanner interpretNextInstructionFor: self]! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 12:14'! doPop "Print the Remove Top Of Stack bytecode." self print: 'pop'! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'! jump: offset "Print the Unconditional Jump bytecode." self print: 'jumpTo: ' , (scanner pc + offset) printString! ! !InstructionPrinter methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 11:13'! jump: offset if: condition "Print the Conditional Jump bytecode." self print: (condition ifTrue: ['jumpTrue: '] ifFalse: ['jumpFalse: ']) , (scanner pc + offset) printString! ! !InstructionPrinter methodsFor: 'printing' stamp: 'laza 3/29/2004 18:45'! print: instruction "Append to the receiver a description of the bytecode, instruction." | code | stream tab: self indent; print: oldPC; space. stream nextPut: $<. oldPC to: scanner pc - 1 do: [:i | code _ (method at: i) radix: 16. stream nextPut: (code size < 2 ifTrue: [$0] ifFalse: [code at: 1]). stream nextPut: code last; space]. stream skip: -1. stream nextPut: $>. stream space. stream nextPutAll: instruction. stream cr. oldPC _ scanner pc. "(InstructionPrinter compiledMethodAt: #print:) symbolic." ! ! !InstructionPrinter methodsFor: 'printing' stamp: 'ajh 6/27/2003 22:26'! pushConstant: obj "Print the Push Constant, obj, on Top Of Stack bytecode." self print: 'pushConstant: ' , (String streamContents: [:s | (obj isKindOf: LookupKey) ifFalse: [s withStyleFor: #literal do: [obj printOn: s]] ifTrue: [obj key ifNotNil: [s nextPutAll: '##'; nextPutAll: obj key] ifNil: [s nextPutAll: '###'; nextPutAll: obj value soleInstance name]] ]). (obj isKindOf: CompiledMethod) ifTrue: [ obj longPrintOn: stream indent: self indent + 2. ^ self]. Smalltalk at: #BlockClosure ifPresent:[:aClass| (obj isKindOf: aClass) ifTrue: [ obj method longPrintOn: stream indent: self indent + 2. ^ self]].! ! !InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0! My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The variable method is used to hold the method being printed.! !InstructionPrinter class methodsFor: 'printing' stamp: 'md 4/8/2003 11:19'! on: aMethod ^self new method: aMethod. ! ! !InstructionPrinterTest methodsFor: 'examples' stamp: 'md 4/8/2003 12:28'! example1 | ff| (1 < 2) ifTrue: [tt ifNotNil: [ff _ 'hallo']]. ^ ff.! ! !InstructionPrinterTest methodsFor: 'testing' stamp: 'md 4/8/2003 12:13'! testInstructions "just print all of methods of Object and see if no error accours" | methods printer | methods := Object methodDict values. printer := InstructionPrinter. methods do: [:method | self shouldnt: [ String streamContents: [:stream | (printer on: method) printInstructionsOn: stream]] raise: Error. ]. ! ! !InstructionPrinterTest commentStamp: '<historical>' prior: 0! This is the unit test for the class InstructionPrinter. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:34'! willBlockReturn ^ (self method at: pc) = Encoder blockReturnCode! ! !InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 11:10'! willJump "unconditionally" | byte | byte _ self method at: pc. ^ (byte between: 144 and: 151) or: [byte between: 160 and: 167]! ! !InstructionStream methodsFor: 'testing' stamp: 'ajh 8/13/2002 17:32'! willJustPop ^ (self method at: pc) = Encoder popCode! ! !InstructionStream methodsFor: 'testing' stamp: 'hmm 7/15/2001 22:00'! willStore "Answer whether the next bytecode is a store or store-pop" | byte | byte _ self method at: pc. ^(byte between: 96 and: 132) and: [ byte <= 111 or: [byte >= 129 and: [ byte <= 130 or: [byte = 132 and: [ (self method at: pc+1) >= 160]]]]]! ! !InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'! atEnd ^ pc > self method endPC! ! !InstructionStream methodsFor: 'decoding' stamp: 'ajh 3/2/2003 14:06'! interpret [self atEnd] whileFalse: [self interpretNextInstructionFor: self]! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:32'! nextInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. This advances the pc by one instruction." ^ self interpretNextInstructionFor: MessageCatcher new! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:36'! peekInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." | currentPc instr | currentPc _ self pc. instr _ self nextInstruction. self pc: currentPc. ^ instr! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:29'! previousPc | currentPc dummy prevPc | currentPc _ pc. pc _ self method initialPC. dummy _ MessageCatcher new. [pc = currentPc] whileFalse: [ prevPc _ pc. self interpretNextInstructionFor: dummy. ]. ^ prevPc! ! !InstructionStream methodsFor: 'scanning' stamp: 'hmm 7/29/2001 21:25'! skipBackBeforeJump "Assuming that the receiver is positioned jast after a jump, skip back one or two bytes, depending on the size of the previous jump instruction." | strm short | strm _ InstructionStream on: self method. (strm scanFor: [:byte | ((short _ byte between: 152 and: 159) or: [byte between: 168 and: 175]) and: [strm pc = (short ifTrue: [pc-1] ifFalse: [pc-2])]]) ifFalse: [self error: 'Where''s the jump??']. self jump: (short ifTrue: [-1] ifFalse: [-2]). ! ! !InstructionStream methodsFor: 'private' stamp: 'ajh 8/1/2001 02:57'! pc: n pc _ n! ! !Integer methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'! // aNumber | q | #Numeric. "Changed 200/01/19 For ANSI support." aNumber = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. self = 0 ifTrue: [^ 0]. q := self quo: aNumber. "Refer to the comment in Number|//." (q negative ifTrue: [q * aNumber ~= self] ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) ifTrue: [^ q - 1"Truncate towards minus infinity."] ifFalse: [^ q]! ! !Integer methodsFor: 'truncation and round off' stamp: 'lr 11/4/2003 12:14'! atRandom "Answer a random integer from 1 to self. This implementation uses a shared generator. Heavy users should their own implementation or use Interval>atRandom: directly." self = 0 ifTrue: [ ^0 ]. self < 0 ifTrue: [ ^self negated atRandom negated ]. ^Collection mutexForPicking critical: [ self atRandom: Collection randomForPicking ]! ! !Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:45'! adaptToComplex: rcvr andSend: selector "If I am involved in arithmetic with a Complex number, convert me to a Complex number." ^ rcvr perform: selector with: self asComplex! ! !Integer methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector "Convert me to a ScaledDecimal and do the arithmetic. receiverScaledDecimal arithmeticOpSelector self." #Numeric. "add 200/01/19 For ScaledDecimal support." ^ receiverScaledDecimal perform: arithmeticOpSelector with: (self asScaledDecimal: 0)! ! !Integer methodsFor: 'converting' stamp: 'yo 8/30/2002 16:32'! asCharacter "Answer the Character whose value is the receiver." self > 255 ifTrue: [^ MultiCharacter value: self] ifFalse: [^ Character value: self] ! ! !Integer methodsFor: 'converting' stamp: 'mk 10/27/2003 17:44'! asComplex "Answer a Complex number that represents value of the the receiver." ^ Complex real: self imaginary: 0! ! !Integer methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! asScaledDecimal: scaleNotUsed "The number of significant digits of the answer is the same as the number of decimal digits in the receiver. The scale of the answer is 0." #Numeric. "add 200/01/19 For <integer> protocol." ^ ScaledDecimal newFromNumber: self scale: 0! ! !Integer methodsFor: 'converting' stamp: 'brp 5/13/2003 10:12'! asYear ^ Year year: self ! ! !Integer methodsFor: 'printing' stamp: 'ar 7/18/2001 22:09'! asStringWithCommasSigned "123456789 asStringWithCommasSigned" "-123456789 asStringWithCommasSigned" | digits | digits _ self abs printString. ^ String streamContents: [:strm | self sign = -1 ifTrue: [strm nextPut: $-] ifFalse:[strm nextPut: $+]. 1 to: digits size do: [:i | strm nextPut: (digits at: i). (i < digits size and: [(i - digits size) \\ 3 = 0]) ifTrue: [strm nextPut: $,]]]! ! !Integer methodsFor: 'printing' stamp: 'tk 4/1/2002 11:30'! asWords "SmallInteger maxVal asWords" | mils minus three num answer milCount | self = 0 ifTrue: [^'zero']. mils _ #('' ' thousand' ' million' ' billion' ' trillion' ' quadrillion' ' quintillion' ' sextillion' ' septillion' ' octillion' ' nonillion' ' decillion' ' undecillion' ' duodecillion' ' tredecillion' ' quattuordecillion' ' quindecillion' ' sexdecillion' ' septendecillion' ' octodecillion' ' novemdecillion' ' vigintillion'). num _ self. minus _ ''. self < 0 ifTrue: [ minus _ 'negative '. num _ num negated. ]. answer _ String new. milCount _ 1. [num > 0] whileTrue: [ three _ (num \\ 1000) threeDigitName. num _ num // 1000. three isEmpty ifFalse: [ answer isEmpty ifFalse: [ answer _ ', ',answer ]. answer _ three,(mils at: milCount),answer. ]. milCount _ milCount + 1. ]. ^minus,answer! ! !Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! printOn: outputStream base: baseInteger showRadix: flagBoolean "Write a sequence of characters that describes the receiver in radix baseInteger with optional radix specifier. The result is undefined if baseInteger less than 2 or greater than 36." | tempString startPos | #Numeric. "2000/03/04 Harmon R. Added ANSI <integer> protocol" tempString := self printStringRadix: baseInteger. flagBoolean ifTrue: [^ outputStream nextPutAll: tempString]. startPos := (tempString indexOf: $r ifAbsent: [self error: 'radix indicator not found.']) + 1. self negative ifTrue: [outputStream nextPut: $-]. outputStream nextPutAll: (tempString copyFrom: startPos to: tempString size)! ! !Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! printPaddedWith: aCharacter to: anInteger "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least anInteger characters." #Numeric. "2000/03/04 Harmon R. Added Date and Time support" ^ self printPaddedWith: aCharacter to: anInteger base: 10! ! !Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! printPaddedWith: aCharacter to: anInteger base: aRadix "Answer the string containing the ASCII representation of the receiver padded on the left with aCharacter to be at least anInteger characters." | aStream padding digits | #Numeric. "2000/03/04 Harmon R. Added Date and Time support" aStream := WriteStream on: (String new: 10). self printOn: aStream base: aRadix showRadix: false. digits := aStream contents. padding := anInteger - digits size. padding > 0 ifFalse: [^ digits]. ^ ((String new: padding) atAllPut: aCharacter; yourself) , digits! ! !Integer methodsFor: 'printing' stamp: 'RAH 4/25/2000 19:49'! printStringRadix: baseInteger "Return a string containing a sequence of characters that represents the numeric value of the receiver in the radix specified by the argument. If the receiver is negative, a minus sign ('-') is prepended to the sequence of characters. The result is undefined if baseInteger less than 2 or greater than 36." | tempString | #Numeric. "2000/03/04 Harmon R. Added ANSI <integer> protocol" baseInteger = 10 ifTrue: [tempString := self printStringBase: baseInteger. self negative ifTrue: [^ '-10r' , (tempString copyFrom: 2 to: tempString size)] ifFalse: [^ '10r' , tempString]]. ^ self printStringBase: baseInteger! ! !Integer methodsFor: 'private' stamp: 'hmm 1/7/2002 20:55'! digitLogic: arg op: op length: len | result neg1 neg2 rneg z1 z2 rz b1 b2 b | neg1 _ self negative. neg2 _ arg negative. rneg _ ((neg1 ifTrue: [-1] ifFalse: [0]) perform: op with: (neg2 ifTrue: [-1] ifFalse: [0])) < 0. result _ Integer new: len neg: rneg. rz _ z1 _ z2 _ true. 1 to: result digitLength do: [:i | b1 _ self digitAt: i. neg1 ifTrue: [b1 _ z1 ifTrue: [b1 = 0 ifTrue: [0] ifFalse: [z1 _ false. 256 - b1]] ifFalse: [255 - b1]]. b2 _ arg digitAt: i. neg2 ifTrue: [b2 _ z2 ifTrue: [b2 = 0 ifTrue: [0] ifFalse: [z2 _ false. 256 - b2]] ifFalse: [255 - b2]]. b _ b1 perform: op with: b2. result digitAt: i put: (rneg ifTrue: [rz ifTrue: [b = 0 ifTrue: [0] ifFalse: [rz _ false. 256 - b]] ifFalse: [255 - b]] ifFalse: [b])]. ^ result normalize! ! !Integer methodsFor: 'private' stamp: 'laza 3/29/2004 18:16'! print: positiveNumberString on: aStream prefix: prefix length: minimum padded: zeroFlag | padLength | padLength _ minimum - positiveNumberString size - prefix size. padLength > 0 ifTrue: [zeroFlag ifTrue: [aStream nextPutAll: prefix; nextPutAll: (String new: padLength withAll: $0)] ifFalse: [aStream nextPutAll: (String new: padLength withAll: Character space); nextPutAll: prefix]] ifFalse: [aStream nextPutAll: prefix]. aStream nextPutAll: positiveNumberString ! ! !Integer methodsFor: 'deprecated' stamp: 'laza 3/29/2004 11:00'! hex self deprecated: 'Use ', self printString, ' printStringHex or ', self printString, ' storeStringHex instead!!'. ^ self storeStringBase: 16! ! !Integer methodsFor: 'deprecated' stamp: 'laza 3/29/2004 18:31'! hex8 "16r3333 hex8" | hex | self deprecated: 'Use ', self printString, ' storeStringBase: 16 length: 11 padded: true instead!!'. hex _ self hex. "16rNNN" hex size < 11 ifTrue: [^ hex copyReplaceFrom: 4 to: 3 with: ('00000000' copyFrom: 1 to: 11-hex size)] ifFalse: [^ hex]! ! !Integer methodsFor: 'deprecated' stamp: 'laza 3/30/2004 14:23'! romanString "1999 romanString" self deprecated: 'Use ', self printString, ' printStringRoman instead!!'. [self > 0] assert. ^ String streamContents: [:s | self // 1000 timesRepeat: [s nextPut: $M]. self romanDigits: 'MDC' for: 100 on: s. self romanDigits: 'CLX' for: 10 on: s. self romanDigits: 'XVI' for: 1 on: s]! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 14:08'! byteEncode: aStream base: base (self printStringBase: base) do: [:each| aStream nextPut: $$; nextPut: each] ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:06'! printOn: aStream base: base aStream nextPutAll: (self printStringBase: base)! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:13'! printOn: aStream base: base length: minimum padded: zeroFlag | prefix | prefix _ self negative ifTrue: ['-'] ifFalse: [String new]. self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 9/19/2004 10:52'! printStringBase: base | stream integer next | self = 0 ifTrue: [^'0']. self negative ifTrue: [^'-', (self negated printStringBase: base)]. stream _ WriteStream on: String new. integer _ self normalize. [integer > 0] whileTrue: [ next _ integer quo: base. stream nextPut: (Character digitValue: integer - (next * base)). integer _ next]. ^stream contents reversed ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:14'! printStringBase: base length: minimum padded: zeroFlag ^String streamContents: [:s| self printOn: s base: base length: minimum padded: zeroFlag]! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'! printStringHex ^self printStringBase: 16! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:21'! printStringLength: minimal ^self printStringLength: minimal padded: false ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringLength: minimal padded: zeroFlag ^self printStringBase: 10 length: minimal padded: zeroFlag! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringPadded: minimal ^self printStringLength: minimal padded: true ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/30/2004 09:40'! printStringRoman | stream integer | stream _ WriteStream on: String new. integer _ self negative ifTrue: [stream nextPut: $-. self negated] ifFalse: [self]. integer // 1000 timesRepeat: [stream nextPut: $M]. integer romanDigits: 'MDC' for: 100 on: stream; romanDigits: 'CLX' for: 10 on: stream; romanDigits: 'XVI' for: 1 on: stream. ^stream contents! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:35'! radix: base ^ self printStringBase: base! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 13:36'! storeOn: aStream base: base "Print a representation of the receiver on the stream <aStream> in base <base> where 2 <= <baseInteger> <= 16. If <base> is other than 10 it is written first separated by $r followed by the number like for example: 16rFCE2" | integer | integer _ self negative ifTrue: [aStream nextPut: $-. self negated] ifFalse: [self]. base = 10 ifFalse: [aStream nextPutAll: base printString; nextPut: $r]. aStream nextPutAll: (integer printStringBase: base). ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'! storeOn: aStream base: base length: minimum padded: zeroFlag | prefix | prefix _ self negative ifTrue: ['-'] ifFalse: [String new]. base = 10 ifFalse: [prefix _ prefix, base printString, 'r']. self print: (self abs printStringBase: base) on: aStream prefix: prefix length: minimum padded: zeroFlag ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:16'! storeStringBase: base length: minimum padded: zeroFlag ^String streamContents: [:s| self storeOn: s base: base length: minimum padded: zeroFlag]! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 10:58'! storeStringHex ^self storeStringBase: 16! ! !Integer class methodsFor: 'instance creation' stamp: 'bf 2/2/2004 00:23'! byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 "Depending on high-order byte copy directly into a LargeInteger, or build up a SmallInteger by shifting" | value | byte4 < 16r40 ifTrue: [^ (byte4 bitShift: 24) + (byte3 bitShift: 16) + (byte2 bitShift: 8) + byte1]. value _ LargePositiveInteger new: 4. value digitAt: 4 put: byte4. value digitAt: 3 put: byte3. value digitAt: 2 put: byte2. value digitAt: 1 put: byte1. ^ value! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:34'! largePrimesUpTo: maxValue "Compute and return all the prime numbers up to maxValue" ^Array streamContents:[:s| self largePrimesUpTo: maxValue do:[:prime| s nextPut: prime]]! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 02:38'! largePrimesUpTo: max do: aBlock "Evaluate aBlock with all primes up to maxValue. The Algorithm is adapted from http://www.rsok.com/~jrm/printprimes.html It encodes prime numbers much more compactly than #primesUpTo: 38.5 integer per byte (2310 numbers per 60 byte) allow for some fun large primes. (all primes up to SmallInteger maxVal can be computed within ~27MB of memory; the regular #primesUpTo: would require 4 *GIGA*bytes). Note: The algorithm could be re-written to produce the first primes (which require the longest time to sieve) faster but only at the cost of clarity." | limit flags maskBitIndex bitIndex maskBit byteIndex index primesUpTo2310 indexLimit | limit _ max asInteger - 1. indexLimit _ max sqrt truncated + 1. "Create the array of flags." flags _ ByteArray new: (limit + 2309) // 2310 * 60 + 60. flags atAllPut: 16rFF. "set all to true" "Compute the primes up to 2310" primesUpTo2310 _ self primesUpTo: 2310. "Create a mapping from 2310 integers to 480 bits (60 byte)" maskBitIndex _ Array new: 2310. bitIndex _ -1. "for pre-increment" maskBitIndex at: 1 put: (bitIndex _ bitIndex + 1). maskBitIndex at: 2 put: (bitIndex _ bitIndex + 1). 1 to: 5 do:[:i| aBlock value: (primesUpTo2310 at: i)]. index _ 6. 2 to: 2309 do:[:n| [(primesUpTo2310 at: index) < n] whileTrue:[index _ index + 1]. n = (primesUpTo2310 at: index) ifTrue:[ maskBitIndex at: n+1 put: (bitIndex _ bitIndex + 1). ] ifFalse:[ "if modulo any of the prime factors of 2310, then could not be prime" (n \\ 2 = 0 or:[n \\ 3 = 0 or:[n \\ 5 = 0 or:[n \\ 7 = 0 or:[n \\ 11 = 0]]]]) ifTrue:[maskBitIndex at: n+1 put: 0] ifFalse:[maskBitIndex at: n+1 put: (bitIndex _ bitIndex + 1)]. ]. ]. "Now the real work begins... Start with 13 since multiples of 2,3,5,7,11 are handled by the storage method; increment by 2 for odd numbers only." 13 to: limit by: 2 do:[:n| (maskBit _ maskBitIndex at: (n \\ 2310 + 1)) = 0 ifFalse:["not a multiple of 2,3,5,7,11" byteIndex _ n // 2310 * 60 + (maskBit-1 bitShift: -3) + 1. bitIndex _ 1 bitShift: (maskBit bitAnd: 7). ((flags at: byteIndex) bitAnd: bitIndex) = 0 ifFalse:["not marked -- n is prime" aBlock value: n. "Start with n*n since any integer < n has already been sieved (e.g., any multiple of n with a number k < n has been cleared when k was sieved); add 2 * i to avoid even numbers and mark all multiples of this prime. Note: n < indexLimit below limits running into LargeInts -- nothing more." n < indexLimit ifTrue:[ index _ n * n. (index bitAnd: 1) = 0 ifTrue:[index _ index + n]. [index <= limit] whileTrue:[ (maskBit _ maskBitIndex at: (index \\ 2310 + 1)) = 0 ifFalse:[ byteIndex _ (index // 2310 * 60) + (maskBit-1 bitShift: -3) + 1. maskBit _ 255 - (1 bitShift: (maskBit bitAnd: 7)). flags at: byteIndex put: ((flags at: byteIndex) bitAnd: maskBit). ]. index _ index + (2 * n)]. ]. ]. ]. ]. ! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! primesUpTo: max "Return a list of prime integers up to the given integer." "Integer primesUpTo: 100" ^Array streamContents:[:s| self primesUpTo: max do:[:prime| s nextPut: prime]]! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! primesUpTo: max do: aBlock "Compute aBlock with all prime integers up to the given integer." "Integer primesUpTo: 100" | limit flags prime k | limit _ max asInteger - 1. "Fall back into #largePrimesUpTo:do: if we'd require more than 100k of memory; the alternative will only requre 1/154th of the amount we need here and is almost as fast." limit > 25000 ifTrue:[^self largePrimesUpTo: max do: aBlock]. flags _ (Array new: limit) atAllPut: true. 1 to: limit do: [:i | (flags at: i) ifTrue: [ prime _ i + 1. k _ i + prime. [k <= limit] whileTrue: [ flags at: k put: false. k _ k + prime]. aBlock value: prime]]. ! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! verbosePrimesUpTo: max "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" "Compute primes up to max, but be verbose about it" ^Array streamContents:[:s| self verbosePrimesUpTo: max do:[:prime| s nextPut: prime]].! ! !Integer class methodsFor: 'prime numbers' stamp: 'ar 10/6/2001 19:33'! verbosePrimesUpTo: max do: aBlock "Integer verbosePrimesUpTo: SmallInteger maxVal" "<- heh, heh" "Compute primes up to max, but be verbose about it" | lastTime nowTime | lastTime _ Time millisecondClockValue. Utilities informUserDuring:[:bar| bar value:'Computing primes...'. self primesUpTo: max do:[:prime| aBlock value: prime. nowTime _ Time millisecondClockValue. (nowTime - lastTime > 1000) ifTrue:[ lastTime _ nowTime. bar value:'Last prime found: ', prime printString]]].! ! !Integer class methodsFor: 'constants' stamp: 'RAH 4/25/2000 19:49'! one #Numeric. "add 200/01/19 For <number> protocol support." ^ 1! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! at: index | word | <primitive: 165> word _ self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 22:40'! at: index put: anInteger | word | <primitive: 166> anInteger < 0 ifTrue:["word _ 16r100000000 + anInteger" word _ (anInteger + 1) negated bitInvert32] ifFalse:[word _ anInteger]. self basicAt: index put: word. ^anInteger! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 23:34'! atAllPut: anInteger | word | anInteger < 0 ifTrue:["word _ 16r100000000 + anInteger" word _ (anInteger + 1) negated bitInvert32] ifFalse:[word _ anInteger]. self primFill: word.! ! !IntegerArray methodsFor: 'private' stamp: 'ar 3/3/2001 23:34'! primFill: aPositiveInteger "Fill the receiver, an indexable bytes or words object, with the given positive integer. The range of possible fill values is [0..255] for byte arrays and [0..(2^32 - 1)] for word arrays." <primitive: 145> self errorImproperStore.! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:12'! testAndSingleBitWithMinusOne "And a single bit with -1 and test for same value" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)].! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:13'! testMixedSignDigitLogic "Verify that mixed sign logic with large integers works." self assert: (-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:12'! testNBitAndNNegatedEqualsN "Verify that (n bitAnd: n negated) = n for single bits" | n | 1 to: 100 do: [:i | n _ 1 bitShift: i. self assert: (n bitAnd: n negated) = n]! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:12'! testNNegatedEqualsNComplementedPlusOne "Verify that n negated = (n complemented + 1) for single bits" | n | 1 to: 100 do: [:i | n _ 1 bitShift: i. self assert: n negated = ((n bitXor: -1) + 1)]! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:13'! testShiftMinusOne1LeftThenRight "Shift -1 left then right and test for 1" 1 to: 100 do: [:i | self assert: ((-1 bitShift: i) bitShift: i negated) = -1]. ! ! !IntegerDigitLogicTest methodsFor: 'running' stamp: 'hmm 1/7/2002 21:12'! testShiftOneLeftThenRight "Shift 1 bit left then right and test for 1" 1 to: 100 do: [:i | self assert: ((1 bitShift: i) bitShift: i negated) = 1]. ! ! !IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:34'! testBenchFib self should: [0 benchFib = 1]. self should: [1 benchFib = 1]. self should: [2 benchFib = 3]. ! ! !IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:34'! testBenchmark self shouldnt: [0 benchmark ] raise: Error. ! ! !IntegerTest methodsFor: 'testing - benchmarks' stamp: 'md 4/15/2003 20:32'! testTinyBenchmarks self shouldnt: [0 tinyBenchmarks] raise: Error.! ! !IntegerTest methodsFor: 'testing - bitLogic' stamp: 'md 3/17/2003 15:27'! testBitLogic "This little suite of tests is designed to verify correct operation of most of Squeak's bit manipulation code, including two's complement representation of negative values. It was written in a hurry and is probably lacking several important checks." "Shift 1 bit left then right and test for 1" | n | 1 to: 100 do: [:i | self should: [((1 bitShift: i) bitShift: i negated) = 1]]. "Shift -1 left then right and test for 1" 1 to: 100 do: [:i | self should: [((-1 bitShift: i) bitShift: i negated) = -1]]. "And a single bit with -1 and test for same value" 1 to: 100 do: [:i | self should: [((1 bitShift: i) bitAnd: -1) = (1 bitShift: i)]]. "Verify that (n bitAnd: n negated) = n for single bits" 1 to: 100 do: [:i | self should: [n _ 1 bitShift: i. (n bitAnd: n negated) = n]]. "Verify that n negated = (n complemented + 1) for single bits" 1 to: 100 do: [:i | self should:[n _ 1 bitShift: i. n negated = ((n bitXor: -1) + 1)]]. "Verify that (n + n complemented) = -1 for single bits" 1 to: 100 do: [:i | self should: [n _ 1 bitShift: i. (n + (n bitXor: -1)) = -1]]. "Verify that n negated = (n complemented +1) for single bits" 1 to: 100 do: [:i | self should: [n _ 1 bitShift: i. n negated = ((n bitXor: -1) + 1)]]. self should: [(-2 bitAnd: 16rFFFFFFFF) = 16rFFFFFFFE].! ! !IntegerTest methodsFor: 'testing - bitLogic' stamp: 'md 3/17/2003 15:10'! testTwoComplementRightShift | large small | small _ 2 << 16. large _ 2 << 32. self should: [(small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1) == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1))]. self should: [ (small bitShift: -1) ~= (small + 1 bitShift: -1) == ((large bitShift: -1) ~= (large + 1 bitShift: -1))].! ! !IntegerTest methodsFor: 'testing - testing' stamp: 'md 4/21/2003 16:17'! testEven self deny: (1073741825 even). self assert: (1073741824 even). ! ! !IntegerTest methodsFor: 'testing - testing' stamp: 'md 4/21/2003 16:14'! testIsInteger self assert: (0 isInteger). ! ! !IntegerTest methodsFor: 'testing - testing' stamp: 'md 4/15/2003 20:40'! testIsPowerOfTwo self assert: (0 isPowerOfTwo). self assert: (1 isPowerOfTwo). self assert: (2 isPowerOfTwo). self deny: (3 isPowerOfTwo). self assert: (4 isPowerOfTwo). ! ! !IntegerTest methodsFor: 'testing - instance creation' stamp: 'laza 3/29/2004 11:28'! testDifferentBases "| value | 2 to: 36 do: [:each| value _ 0. 1 to: each-1 do: [:n| value _ value + (n * (each raisedToInteger: n))]. value _ value negated. Transcript tab; show: 'self assert: (', value printString, ' printStringBase: ', each printString, ') = ''', (value printStringBase: each), '''.'; cr. Transcript tab; show: 'self assert: (', value printString, ' radix: ', each printString, ') = ''', (value radix: each), '''.'; cr. Transcript tab; show: 'self assert: ', value printString, ' printStringHex = ''', (value printStringBase: 16), '''.'; cr. Transcript tab; show: 'self assert: (', value printString, ' storeStringBase: ', each printString, ') = ''', (value storeStringBase: each), '''.'; cr. Transcript tab; show: 'self assert: ', value printString, ' storeStringHex = ''', (value storeStringBase: 16), '''.'; cr. ]. " self assert: 2r10 = 2. self assert: 3r210 = 21. self assert: 4r3210 = 228. self assert: 5r43210 = 2930. self assert: 6r543210 = 44790. self assert: 7r6543210 = 800667. self assert: 8r76543210 = 16434824. self assert: 9r876543210 = 381367044. self assert: 10r9876543210 = 9876543210. self assert: 11rA9876543210 = 282458553905. self assert: 12rBA9876543210 = 8842413667692. self assert: 13rCBA9876543210 = 300771807240918. self assert: 14rDCBA9876543210 = 11046255305880158. self assert: 15rEDCBA9876543210 = 435659737878916215. self assert: 16rFEDCBA9876543210 = 18364758544493064720. self assert: 17rGFEDCBA9876543210 = 824008854613343261192. self assert: 18rHGFEDCBA9876543210 = 39210261334551566857170. self assert: 19rIHGFEDCBA9876543210 = 1972313422155189164466189. self assert: 20rJIHGFEDCBA9876543210 = 104567135734072022160664820. self assert: 21rKJIHGFEDCBA9876543210 = 5827980550840017565077671610. self assert: 22rLKJIHGFEDCBA9876543210 = 340653664490377789692799452102. self assert: 23rMLKJIHGFEDCBA9876543210 = 20837326537038308910317109288851. self assert: 24rNMLKJIHGFEDCBA9876543210 = 1331214537196502869015340298036888. self assert: 25rONMLKJIHGFEDCBA9876543210 = 88663644327703473714387251271141900. self assert: 26rPONMLKJIHGFEDCBA9876543210 = 6146269788878825859099399609538763450. self assert: 27rQPONMLKJIHGFEDCBA9876543210 = 442770531899482980347734468443677777577. self assert: 28rRQPONMLKJIHGFEDCBA9876543210 = 33100056003358651440264672384704297711484. self assert: 29rSRQPONMLKJIHGFEDCBA9876543210 = 2564411043271974895869785066497940850811934. self assert: 30rTSRQPONMLKJIHGFEDCBA9876543210 = 205646315052919334126040428061831153388822830. self assert: 31rUTSRQPONMLKJIHGFEDCBA9876543210 = 17050208381689099029767742314582582184093573615. self assert: 32rVUTSRQPONMLKJIHGFEDCBA9876543210 = 1459980823972598128486511383358617792788444579872. self assert: 33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = 128983956064237823710866404905431464703849549412368. self assert: 34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 11745843093701610854378775891116314824081102660800418. self assert: 35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 1101553773143634726491620528194292510495517905608180485. self assert: 36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = 106300512100105327644605138221229898724869759421181854980. self assert: -2r10 = -2. self assert: -3r210 = -21. self assert: -4r3210 = -228. self assert: -5r43210 = -2930. self assert: -6r543210 = -44790. self assert: -7r6543210 = -800667. self assert: -8r76543210 = -16434824. self assert: -9r876543210 = -381367044. self assert: -10r9876543210 = -9876543210. self assert: -11rA9876543210 = -282458553905. self assert: -12rBA9876543210 = -8842413667692. self assert: -13rCBA9876543210 = -300771807240918. self assert: -14rDCBA9876543210 = -11046255305880158. self assert: -15rEDCBA9876543210 = -435659737878916215. self assert: -16rFEDCBA9876543210 = -18364758544493064720. self assert: -17rGFEDCBA9876543210 = -824008854613343261192. self assert: -18rHGFEDCBA9876543210 = -39210261334551566857170. self assert: -19rIHGFEDCBA9876543210 = -1972313422155189164466189. self assert: -20rJIHGFEDCBA9876543210 = -104567135734072022160664820. self assert: -21rKJIHGFEDCBA9876543210 = -5827980550840017565077671610. self assert: -22rLKJIHGFEDCBA9876543210 = -340653664490377789692799452102. self assert: -23rMLKJIHGFEDCBA9876543210 = -20837326537038308910317109288851. self assert: -24rNMLKJIHGFEDCBA9876543210 = -1331214537196502869015340298036888. self assert: -25rONMLKJIHGFEDCBA9876543210 = -88663644327703473714387251271141900. self assert: -26rPONMLKJIHGFEDCBA9876543210 = -6146269788878825859099399609538763450. self assert: -27rQPONMLKJIHGFEDCBA9876543210 = -442770531899482980347734468443677777577. self assert: -28rRQPONMLKJIHGFEDCBA9876543210 = -33100056003358651440264672384704297711484. self assert: -29rSRQPONMLKJIHGFEDCBA9876543210 = -2564411043271974895869785066497940850811934. self assert: -30rTSRQPONMLKJIHGFEDCBA9876543210 = -205646315052919334126040428061831153388822830. self assert: -31rUTSRQPONMLKJIHGFEDCBA9876543210 = -17050208381689099029767742314582582184093573615. self assert: -32rVUTSRQPONMLKJIHGFEDCBA9876543210 = -1459980823972598128486511383358617792788444579872. self assert: -33rWVUTSRQPONMLKJIHGFEDCBA9876543210 = -128983956064237823710866404905431464703849549412368. self assert: -34rXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -11745843093701610854378775891116314824081102660800418. self assert: -35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -1101553773143634726491620528194292510495517905608180485. self assert: -36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210 = -106300512100105327644605138221229898724869759421181854980.! ! !IntegerTest methodsFor: 'testing - instance creation' stamp: 'md 3/25/2003 23:14'! testNew self should: [Integer new] raise: TestResult error. ! ! !IntegerTest methodsFor: 'testing - instance creation' stamp: 'dtl 9/18/2004 17:14'! testReadFrom "Ensure remaining characters in a stream are not lost when parsing an integer." | rs i s | rs _ ReadStream on: '123s could be confused with a ScaledDecimal'. i _ Number readFrom: rs. self assert: i == 123. s _ rs upToEnd. self assert: 's could be confused with a ScaledDecimal' = s. rs _ ReadStream on: '123.s could be confused with a ScaledDecimal'. i _ Number readFrom: rs. self assert: i == 123. s _ rs upToEnd. self assert: '.s could be confused with a ScaledDecimal' = s ! ! !IntegerTest methodsFor: 'testing - instance creation' stamp: 'dtl 9/18/2004 17:07'! testStringAsNumber "This covers parsing in Number>>readFrom: Trailing decimal points should be ignored." self assert: ('123' asNumber == 123). self assert: ('-123' asNumber == -123). self assert: ('123.' asNumber == 123). self assert: ('-123.' asNumber == -123). self assert: ('123This is not to be read' asNumber == 123). self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123). self assert: ('123e could be confused with a Float' asNumber == 123). ! ! !IntegerTest methodsFor: 'testing - Class Methods' stamp: 'md 4/21/2003 16:12'! testPrimesUpTo |primes| primes := Integer primesUpTo: 100. self assert: primes = #(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97).! ! !IntegerTest methodsFor: 'testing' stamp: 'laza 3/29/2004 11:20'! testCreationFromBytes1 "self run: #testCreationFromBytes1" " it is illegal for a LargeInteger to be less than SmallInteger maxVal." " here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs SmallInteger maxVal as an instance of SmallInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := maxSmallInt printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = maxSmallInt. self assert: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'testing' stamp: 'laza 3/29/2004 11:20'! testCreationFromBytes2 "self run: #testCreationFromBytes2" " it is illegal for a LargeInteger to be less than SmallInteger maxVal." " here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal + 1) as an instance of LargePositiveInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := (maxSmallInt + 1) printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = (maxSmallInt + 1). self deny: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'testing' stamp: 'laza 3/29/2004 11:21'! testCreationFromBytes3 "self run: #testCreationFromBytes3" " it is illegal for a LargeInteger to be less than SmallInteger maxVal." " here we test that Integer>>byte!!byte2:byte3:byte4: resconstructs (SmallInteger maxVal - 1) as an instance of SmallInteger. " | maxSmallInt hexString byte1 byte2 byte3 byte4 builtInteger | maxSmallInt := SmallInteger maxVal. hexString := (maxSmallInt - 1) printStringHex. self assert: hexString size = 8. byte4 := Number readFrom: (hexString copyFrom: 1 to: 2) base: 16. byte3 := Number readFrom: (hexString copyFrom: 3 to: 4) base: 16. byte2 := Number readFrom: (hexString copyFrom: 5 to: 6) base: 16. byte1 := Number readFrom: (hexString copyFrom: 7 to: 8) base: 16. builtInteger := Integer byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4. self assert: builtInteger = (maxSmallInt - 1). self assert: builtInteger class = SmallInteger ! ! !IntegerTest methodsFor: 'testing - math' stamp: 'sd 3/5/2004 14:50'! testDegreeCos "self run: #testDegreeCos" self shouldnt: [ 45 degreeCos] raise: Error. self assert: 45 degreeCos printString = (2 sqrt / 2) asFloat printString ! ! !IntegerTest methodsFor: 'testing - printing' stamp: 'md 10/20/2004 15:20'! testIntegerByteEncoded self assert: (String streamContents: [:s| 2 byteEncode: s base: 2]) = '$1$0'. self assert: (String streamContents: [:s| 21 byteEncode: s base: 3]) = '$2$1$0'. self assert: (String streamContents: [:s| 228 byteEncode: s base: 4]) = '$3$2$1$0'. self assert: (String streamContents: [:s| 2930 byteEncode: s base: 5]) = '$4$3$2$1$0'. self assert: (String streamContents: [:s| 44790 byteEncode: s base: 6]) = '$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 800667 byteEncode: s base: 7]) = '$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 16434824 byteEncode: s base: 8]) = '$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 381367044 byteEncode: s base: 9]) = '$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 9876543210 byteEncode: s base: 10]) = '$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 282458553905 byteEncode: s base: 11]) = '$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 8842413667692 byteEncode: s base: 12]) = '$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 300771807240918 byteEncode: s base: 13]) = '$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 11046255305880158 byteEncode: s base: 14]) = '$D$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 435659737878916215 byteEncode: s base: 15]) = '$E$D$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| 18364758544493064720 byteEncode: s base: 16]) = '$F$E$D$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -2 byteEncode: s base: 2]) = '$-$1$0'. self assert: (String streamContents: [:s| -21 byteEncode: s base: 3]) = '$-$2$1$0'. self assert: (String streamContents: [:s| -228 byteEncode: s base: 4]) = '$-$3$2$1$0'. self assert: (String streamContents: [:s| -2930 byteEncode: s base: 5]) = '$-$4$3$2$1$0'. self assert: (String streamContents: [:s| -44790 byteEncode: s base: 6]) = '$-$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -800667 byteEncode: s base: 7]) = '$-$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -16434824 byteEncode: s base: 8]) = '$-$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -381367044 byteEncode: s base: 9]) = '$-$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -9876543210 byteEncode: s base: 10]) = '$-$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -282458553905 byteEncode: s base: 11]) = '$-$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -8842413667692 byteEncode: s base: 12]) = '$-$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -300771807240918 byteEncode: s base: 13]) = '$-$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -11046255305880158 byteEncode: s base: 14]) = '$-$D$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -435659737878916215 byteEncode: s base: 15]) = '$-$E$D$C$B$A$9$8$7$6$5$4$3$2$1$0'. self assert: (String streamContents: [:s| -18364758544493064720 byteEncode: s base: 16]) = '$-$F$E$D$C$B$A$9$8$7$6$5$4$3$2$1$0'.! ! !IntegerTest methodsFor: 'testing - printing' stamp: 'laza 3/29/2004 18:16'! testIntegerPadding "self run: #testIntegerPadding" self assert: (1 printStringBase: 10 length: 0 padded: false) = '1'. self assert: (1 printStringBase: 10 length: 1 padded: false) = '1'. self assert: (1 printStringBase: 10 length: 2 padded: false) = ' 1'. self assert: (1024 printStringBase: 10 length: 19 padded: false) = ' 1024'. self assert: (1024 printStringBase: 10 length: -1 padded: false) = '1024'. self assert: (1024 printStringBase: 10 length: 5 padded: false) = ' 1024'. self assert: (-1024 printStringBase: 10 length: 5 padded: false) = '-1024'. self assert: (-1024 printStringBase: 10 length: 19 padded: false) = ' -1024'. self assert: (1 printStringBase: 10 length: 0 padded: true) = '1'. self assert: (1 printStringBase: 10 length: 1 padded: true) = '1'. self assert: (1 printStringBase: 10 length: 2 padded: true) = '01'. self assert: (1024 printStringBase: 10 length: 19 padded: true) = '0000000000000001024'. self assert: (1024 printStringBase: 10 length: -1 padded: true) = '1024'. self assert: (1024 printStringBase: 10 length: 5 padded: true) = '01024'. self assert: (-1024 printStringBase: 10 length: 5 padded: true) = '-1024'. self assert: (-1024 printStringBase: 10 length: 19 padded: true) = '-000000000000001024'. self assert: (1 printStringBase: 16 length: 0 padded: false) = '1'. self assert: (1 printStringBase: 16 length: 1 padded: false) = '1'. self assert: (1 printStringBase: 16 length: 2 padded: false) = ' 1'. self assert: (2047 printStringBase: 16 length: 19 padded: false) = ' 7FF'. self assert: (2047 printStringBase: 16 length: -1 padded: false) = '7FF'. self assert: (2047 printStringBase: 16 length: 4 padded: false) = ' 7FF'. self assert: (-2047 printStringBase: 16 length: 4 padded: false) = '-7FF'. self assert: (-2047 printStringBase: 16 length: 19 padded: false) = ' -7FF'. self assert: (1 printStringBase: 16 length: 0 padded: true) = '1'. self assert: (1 printStringBase: 16 length: 1 padded: true) = '1'. self assert: (1 printStringBase: 16 length: 2 padded: true) = '01'. self assert: (2047 printStringBase: 16 length: 19 padded: true) = '00000000000000007FF'. self assert: (2047 printStringBase: 16 length: -1 padded: true) = '7FF'. self assert: (2047 printStringBase: 16 length: 4 padded: true) = '07FF'. self assert: (-2047 printStringBase: 16 length: 4 padded: true) = '-7FF'. self assert: (-2047 printStringBase: 16 length: 19 padded: true) = '-0000000000000007FF'. self assert: (1 storeStringBase: 10 length: 0 padded: false) = '1'. self assert: (1 storeStringBase: 10 length: 1 padded: false) = '1'. self assert: (1 storeStringBase: 10 length: 2 padded: false) = ' 1'. self assert: (1024 storeStringBase: 10 length: 19 padded: false) = ' 1024'. self assert: (1024 storeStringBase: 10 length: -1 padded: false) = '1024'. self assert: (1024 storeStringBase: 10 length: 5 padded: false) = ' 1024'. self assert: (-1024 storeStringBase: 10 length: 5 padded: false) = '-1024'. self assert: (-1024 storeStringBase: 10 length: 19 padded: false) = ' -1024'. self assert: (1 storeStringBase: 10 length: 0 padded: true) = '1'. self assert: (1 storeStringBase: 10 length: 1 padded: true) = '1'. self assert: (1 storeStringBase: 10 length: 2 padded: true) = '01'. self assert: (1024 storeStringBase: 10 length: 19 padded: true) = '0000000000000001024'. self assert: (1024 storeStringBase: 10 length: -1 padded: true) = '1024'. self assert: (1024 storeStringBase: 10 length: 5 padded: true) = '01024'. self assert: (-1024 storeStringBase: 10 length: 5 padded: true) = '-1024'. self assert: (-1024 storeStringBase: 10 length: 19 padded: true) = '-000000000000001024'. self assert: (1 storeStringBase: 16 length: 0 padded: false) = '16r1'. self assert: (1 storeStringBase: 16 length: 4 padded: false) = '16r1'. self assert: (1 storeStringBase: 16 length: 5 padded: false) = ' 16r1'. self assert: (2047 storeStringBase: 16 length: 19 padded: false) = ' 16r7FF'. self assert: (2047 storeStringBase: 16 length: -1 padded: false) = '16r7FF'. self assert: (2047 storeStringBase: 16 length: 7 padded: false) = ' 16r7FF'. self assert: (-2047 storeStringBase: 16 length: 7 padded: false) = '-16r7FF'. self assert: (-2047 storeStringBase: 16 length: 19 padded: false) = ' -16r7FF'. self assert: (1 storeStringBase: 16 length: 0 padded: true) = '16r1'. self assert: (1 storeStringBase: 16 length: 4 padded: true) = '16r1'. self assert: (1 storeStringBase: 16 length: 5 padded: true) = '16r01'. self assert: (2047 storeStringBase: 16 length: 19 padded: true) = '16r00000000000007FF'. self assert: (2047 storeStringBase: 16 length: -1 padded: true) = '16r7FF'. self assert: (2047 storeStringBase: 16 length: 7 padded: true) = '16r07FF'. self assert: (-2047 storeStringBase: 16 length: 7 padded: true) = '-16r7FF'. self assert: (-2047 storeStringBase: 16 length: 19 padded: true) = '-16r0000000000007FF'. ! ! !IntegerTest methodsFor: 'testing - printing' stamp: 'laza 3/30/2004 14:20'! testNegativeIntegerPrinting "self run: #testnegativeIntegerPrinting" self assert: (-2 printStringBase: 2) = '-10'. self assert: (-2 radix: 2) = '-10'. self assert: -2 printStringHex = '-2'. self assert: (-2 storeStringBase: 2) = '-2r10'. self assert: -2 storeStringHex = '-16r2'. self assert: (-21 printStringBase: 3) = '-210'. self assert: (-21 radix: 3) = '-210'. self assert: -21 printStringHex = '-15'. self assert: (-21 storeStringBase: 3) = '-3r210'. self assert: -21 storeStringHex = '-16r15'. self assert: (-228 printStringBase: 4) = '-3210'. self assert: (-228 radix: 4) = '-3210'. self assert: -228 printStringHex = '-E4'. self assert: (-228 storeStringBase: 4) = '-4r3210'. self assert: -228 storeStringHex = '-16rE4'. self assert: (-2930 printStringBase: 5) = '-43210'. self assert: (-2930 radix: 5) = '-43210'. self assert: -2930 printStringHex = '-B72'. self assert: (-2930 storeStringBase: 5) = '-5r43210'. self assert: -2930 storeStringHex = '-16rB72'. self assert: (-44790 printStringBase: 6) = '-543210'. self assert: (-44790 radix: 6) = '-543210'. self assert: -44790 printStringHex = '-AEF6'. self assert: (-44790 storeStringBase: 6) = '-6r543210'. self assert: -44790 storeStringHex = '-16rAEF6'. self assert: (-800667 printStringBase: 7) = '-6543210'. self assert: (-800667 radix: 7) = '-6543210'. self assert: -800667 printStringHex = '-C379B'. self assert: (-800667 storeStringBase: 7) = '-7r6543210'. self assert: -800667 storeStringHex = '-16rC379B'. self assert: (-16434824 printStringBase: 8) = '-76543210'. self assert: (-16434824 radix: 8) = '-76543210'. self assert: -16434824 printStringHex = '-FAC688'. self assert: (-16434824 storeStringBase: 8) = '-8r76543210'. self assert: -16434824 storeStringHex = '-16rFAC688'. self assert: (-381367044 printStringBase: 9) = '-876543210'. self assert: (-381367044 radix: 9) = '-876543210'. self assert: -381367044 printStringHex = '-16BB3304'. self assert: (-381367044 storeStringBase: 9) = '-9r876543210'. self assert: -381367044 storeStringHex = '-16r16BB3304'. self assert: (-9876543210 printStringBase: 10) = '-9876543210'. self assert: (-9876543210 radix: 10) = '-9876543210'. self assert: -9876543210 printStringHex = '-24CB016EA'. self assert: (-9876543210 storeStringBase: 10) = '-9876543210'. self assert: -9876543210 storeStringHex = '-16r24CB016EA'. self assert: (-282458553905 printStringBase: 11) = '-A9876543210'. self assert: (-282458553905 radix: 11) = '-A9876543210'. self assert: -282458553905 printStringHex = '-41C3D77E31'. self assert: (-282458553905 storeStringBase: 11) = '-11rA9876543210'. self assert: -282458553905 storeStringHex = '-16r41C3D77E31'. self assert: (-8842413667692 printStringBase: 12) = '-BA9876543210'. self assert: (-8842413667692 radix: 12) = '-BA9876543210'. self assert: -8842413667692 printStringHex = '-80AC8ECF56C'. self assert: (-8842413667692 storeStringBase: 12) = '-12rBA9876543210'. self assert: -8842413667692 storeStringHex = '-16r80AC8ECF56C'. self assert: (-300771807240918 printStringBase: 13) = '-CBA9876543210'. self assert: (-300771807240918 radix: 13) = '-CBA9876543210'. self assert: -300771807240918 printStringHex = '-1118CE4BAA2D6'. self assert: (-300771807240918 storeStringBase: 13) = '-13rCBA9876543210'. self assert: -300771807240918 storeStringHex = '-16r1118CE4BAA2D6'. self assert: (-11046255305880158 printStringBase: 14) = '-DCBA9876543210'. self assert: (-11046255305880158 radix: 14) = '-DCBA9876543210'. self assert: -11046255305880158 printStringHex = '-273E82BB9AF25E'. self assert: (-11046255305880158 storeStringBase: 14) = '-14rDCBA9876543210'. self assert: -11046255305880158 storeStringHex = '-16r273E82BB9AF25E'. self assert: (-435659737878916215 printStringBase: 15) = '-EDCBA9876543210'. self assert: (-435659737878916215 radix: 15) = '-EDCBA9876543210'. self assert: -435659737878916215 printStringHex = '-60BC6392F366C77'. self assert: (-435659737878916215 storeStringBase: 15) = '-15rEDCBA9876543210'. self assert: -435659737878916215 storeStringHex = '-16r60BC6392F366C77'. self assert: (-18364758544493064720 printStringBase: 16) = '-FEDCBA9876543210'. self assert: (-18364758544493064720 radix: 16) = '-FEDCBA9876543210'. self assert: -18364758544493064720 printStringHex = '-FEDCBA9876543210'. self assert: (-18364758544493064720 storeStringBase: 16) = '-16rFEDCBA9876543210'. self assert: -18364758544493064720 storeStringHex = '-16rFEDCBA9876543210'. self assert: (-824008854613343261192 printStringBase: 17) = '-GFEDCBA9876543210'. self assert: (-824008854613343261192 radix: 17) = '-GFEDCBA9876543210'. self assert: -824008854613343261192 printStringHex = '-2CAB6B877C1CD2D208'. self assert: (-824008854613343261192 storeStringBase: 17) = '-17rGFEDCBA9876543210'. self assert: -824008854613343261192 storeStringHex = '-16r2CAB6B877C1CD2D208'. self assert: (-39210261334551566857170 printStringBase: 18) = '-HGFEDCBA9876543210'. self assert: (-39210261334551566857170 radix: 18) = '-HGFEDCBA9876543210'. self assert: -39210261334551566857170 printStringHex = '-84D97AFCAE81415B3D2'. self assert: (-39210261334551566857170 storeStringBase: 18) = '-18rHGFEDCBA9876543210'. self assert: -39210261334551566857170 storeStringHex = '-16r84D97AFCAE81415B3D2'. self assert: (-1972313422155189164466189 printStringBase: 19) = '-IHGFEDCBA9876543210'. self assert: (-1972313422155189164466189 radix: 19) = '-IHGFEDCBA9876543210'. self assert: -1972313422155189164466189 printStringHex = '-1A1A75329C5C6FC00600D'. self assert: (-1972313422155189164466189 storeStringBase: 19) = '-19rIHGFEDCBA9876543210'. self assert: -1972313422155189164466189 storeStringHex = '-16r1A1A75329C5C6FC00600D'. self assert: (-104567135734072022160664820 printStringBase: 20) = '-JIHGFEDCBA9876543210'. self assert: (-104567135734072022160664820 radix: 20) = '-JIHGFEDCBA9876543210'. self assert: -104567135734072022160664820 printStringHex = '-567EF3C9636D242A8C68F4'. self assert: (-104567135734072022160664820 storeStringBase: 20) = '-20rJIHGFEDCBA9876543210'. self assert: -104567135734072022160664820 storeStringHex = '-16r567EF3C9636D242A8C68F4'. self assert: (-5827980550840017565077671610 printStringBase: 21) = '-KJIHGFEDCBA9876543210'. self assert: (-5827980550840017565077671610 radix: 21) = '-KJIHGFEDCBA9876543210'. self assert: -5827980550840017565077671610 printStringHex = '-12D4CAE2B8A09BCFDBE30EBA'. self assert: (-5827980550840017565077671610 storeStringBase: 21) = '-21rKJIHGFEDCBA9876543210'. self assert: -5827980550840017565077671610 storeStringHex = '-16r12D4CAE2B8A09BCFDBE30EBA'. self assert: (-340653664490377789692799452102 printStringBase: 22) = '-LKJIHGFEDCBA9876543210'. self assert: (-340653664490377789692799452102 radix: 22) = '-LKJIHGFEDCBA9876543210'. self assert: -340653664490377789692799452102 printStringHex = '-44CB61B5B47E1A5D8F88583C6'. self assert: (-340653664490377789692799452102 storeStringBase: 22) = '-22rLKJIHGFEDCBA9876543210'. self assert: -340653664490377789692799452102 storeStringHex = '-16r44CB61B5B47E1A5D8F88583C6'. self assert: (-20837326537038308910317109288851 printStringBase: 23) = '-MLKJIHGFEDCBA9876543210'. self assert: (-20837326537038308910317109288851 radix: 23) = '-MLKJIHGFEDCBA9876543210'. self assert: -20837326537038308910317109288851 printStringHex = '-1070108876456E0EF115B389F93'. self assert: (-20837326537038308910317109288851 storeStringBase: 23) = '-23rMLKJIHGFEDCBA9876543210'. self assert: -20837326537038308910317109288851 storeStringHex = '-16r1070108876456E0EF115B389F93'. self assert: (-1331214537196502869015340298036888 printStringBase: 24) = '-NMLKJIHGFEDCBA9876543210'. self assert: (-1331214537196502869015340298036888 radix: 24) = '-NMLKJIHGFEDCBA9876543210'. self assert: -1331214537196502869015340298036888 printStringHex = '-41A24A285154B026B6ED206C6698'. self assert: (-1331214537196502869015340298036888 storeStringBase: 24) = '-24rNMLKJIHGFEDCBA9876543210'. self assert: -1331214537196502869015340298036888 storeStringHex = '-16r41A24A285154B026B6ED206C6698'. self assert: (-88663644327703473714387251271141900 printStringBase: 25) = '-ONMLKJIHGFEDCBA9876543210'. self assert: (-88663644327703473714387251271141900 radix: 25) = '-ONMLKJIHGFEDCBA9876543210'. self assert: -88663644327703473714387251271141900 printStringHex = '-111374860A2C6CEBE5999630398A0C'. self assert: (-88663644327703473714387251271141900 storeStringBase: 25) = '-25rONMLKJIHGFEDCBA9876543210'. self assert: -88663644327703473714387251271141900 storeStringHex = '-16r111374860A2C6CEBE5999630398A0C'. self assert: (-6146269788878825859099399609538763450 printStringBase: 26) = '-PONMLKJIHGFEDCBA9876543210'. self assert: (-6146269788878825859099399609538763450 radix: 26) = '-PONMLKJIHGFEDCBA9876543210'. self assert: -6146269788878825859099399609538763450 printStringHex = '-49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (-6146269788878825859099399609538763450 storeStringBase: 26) = '-26rPONMLKJIHGFEDCBA9876543210'. self assert: -6146269788878825859099399609538763450 storeStringHex = '-16r49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (-442770531899482980347734468443677777577 printStringBase: 27) = '-QPONMLKJIHGFEDCBA9876543210'. self assert: (-442770531899482980347734468443677777577 radix: 27) = '-QPONMLKJIHGFEDCBA9876543210'. self assert: -442770531899482980347734468443677777577 printStringHex = '-14D1A80A997343640C1145A073731DEA9'. self assert: (-442770531899482980347734468443677777577 storeStringBase: 27) = '-27rQPONMLKJIHGFEDCBA9876543210'. self assert: -442770531899482980347734468443677777577 storeStringHex = '-16r14D1A80A997343640C1145A073731DEA9'. self assert: (-33100056003358651440264672384704297711484 printStringBase: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. self assert: (-33100056003358651440264672384704297711484 radix: 28) = '-RQPONMLKJIHGFEDCBA9876543210'. self assert: -33100056003358651440264672384704297711484 printStringHex = '-6145B6E6DACFA25D0E936F51D25932377C'. self assert: (-33100056003358651440264672384704297711484 storeStringBase: 28) = '-28rRQPONMLKJIHGFEDCBA9876543210'. self assert: -33100056003358651440264672384704297711484 storeStringHex = '-16r6145B6E6DACFA25D0E936F51D25932377C'. self assert: (-2564411043271974895869785066497940850811934 printStringBase: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. self assert: (-2564411043271974895869785066497940850811934 radix: 29) = '-SRQPONMLKJIHGFEDCBA9876543210'. self assert: -2564411043271974895869785066497940850811934 printStringHex = '-1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (-2564411043271974895869785066497940850811934 storeStringBase: 29) = '-29rSRQPONMLKJIHGFEDCBA9876543210'. self assert: -2564411043271974895869785066497940850811934 storeStringHex = '-16r1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (-205646315052919334126040428061831153388822830 printStringBase: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-205646315052919334126040428061831153388822830 radix: 30) = '-TSRQPONMLKJIHGFEDCBA9876543210'. self assert: -205646315052919334126040428061831153388822830 printStringHex = '-938B4343B54B550989989D02998718FFB212E'. self assert: (-205646315052919334126040428061831153388822830 storeStringBase: 30) = '-30rTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -205646315052919334126040428061831153388822830 storeStringHex = '-16r938B4343B54B550989989D02998718FFB212E'. self assert: (-17050208381689099029767742314582582184093573615 printStringBase: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-17050208381689099029767742314582582184093573615 radix: 31) = '-UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -17050208381689099029767742314582582184093573615 printStringHex = '-2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (-17050208381689099029767742314582582184093573615 storeStringBase: 31) = '-31rUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -17050208381689099029767742314582582184093573615 storeStringHex = '-16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (-1459980823972598128486511383358617792788444579872 printStringBase: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-1459980823972598128486511383358617792788444579872 radix: 32) = '-VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1459980823972598128486511383358617792788444579872 printStringHex = '-FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (-1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '-32rVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1459980823972598128486511383358617792788444579872 storeStringHex = '-16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (-128983956064237823710866404905431464703849549412368 printStringBase: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-128983956064237823710866404905431464703849549412368 radix: 33) = '-WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -128983956064237823710866404905431464703849549412368 printStringHex = '-584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (-128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '-33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -128983956064237823710866404905431464703849549412368 storeStringHex = '-16r584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (-11745843093701610854378775891116314824081102660800418 printStringBase: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-11745843093701610854378775891116314824081102660800418 radix: 34) = '-XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -11745843093701610854378775891116314824081102660800418 printStringHex = '-1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (-11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '-34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -11745843093701610854378775891116314824081102660800418 storeStringHex = '-16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (-1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-1101553773143634726491620528194292510495517905608180485 radix: 35) = '-YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1101553773143634726491620528194292510495517905608180485 printStringHex = '-B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (-1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '-35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -1101553773143634726491620528194292510495517905608180485 storeStringHex = '-16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (-106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (-106300512100105327644605138221229898724869759421181854980 radix: 36) = '-ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -106300512100105327644605138221229898724869759421181854980 printStringHex = '-455D441E55A37239AB4C303189576071AF5578FFCA80504'. self assert: (-106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '-36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: -106300512100105327644605138221229898724869759421181854980 storeStringHex = '-16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! !IntegerTest methodsFor: 'testing - printing' stamp: 'laza 3/30/2004 11:52'! testPositiveIntegerPrinting "self run: #testPositiveIntegerPrinting" self assert: 0 printString = '0'. self assert: 0 printStringHex = '0'. self assert: 0 storeStringHex = '16r0'. self assert: (2 printStringBase: 2) = '10'. self assert: (2 radix: 2) = '10'. self assert: 2 printStringHex = '2'. self assert: (2 storeStringBase: 2) = '2r10'. self assert: 2 storeStringHex = '16r2'. self assert: (21 printStringBase: 3) = '210'. self assert: (21 radix: 3) = '210'. self assert: 21 printStringHex = '15'. self assert: (21 storeStringBase: 3) = '3r210'. self assert: 21 storeStringHex = '16r15'. self assert: (228 printStringBase: 4) = '3210'. self assert: (228 radix: 4) = '3210'. self assert: 228 printStringHex = 'E4'. self assert: (228 storeStringBase: 4) = '4r3210'. self assert: 228 storeStringHex = '16rE4'. self assert: (2930 printStringBase: 5) = '43210'. self assert: (2930 radix: 5) = '43210'. self assert: 2930 printStringHex = 'B72'. self assert: (2930 storeStringBase: 5) = '5r43210'. self assert: 2930 storeStringHex = '16rB72'. self assert: (44790 printStringBase: 6) = '543210'. self assert: (44790 radix: 6) = '543210'. self assert: 44790 printStringHex = 'AEF6'. self assert: (44790 storeStringBase: 6) = '6r543210'. self assert: 44790 storeStringHex = '16rAEF6'. self assert: (800667 printStringBase: 7) = '6543210'. self assert: (800667 radix: 7) = '6543210'. self assert: 800667 printStringHex = 'C379B'. self assert: (800667 storeStringBase: 7) = '7r6543210'. self assert: 800667 storeStringHex = '16rC379B'. self assert: (16434824 printStringBase: 8) = '76543210'. self assert: (16434824 radix: 8) = '76543210'. self assert: 16434824 printStringHex = 'FAC688'. self assert: (16434824 storeStringBase: 8) = '8r76543210'. self assert: 16434824 storeStringHex = '16rFAC688'. self assert: (381367044 printStringBase: 9) = '876543210'. self assert: (381367044 radix: 9) = '876543210'. self assert: 381367044 printStringHex = '16BB3304'. self assert: (381367044 storeStringBase: 9) = '9r876543210'. self assert: 381367044 storeStringHex = '16r16BB3304'. self assert: (9876543210 printStringBase: 10) = '9876543210'. self assert: (9876543210 radix: 10) = '9876543210'. self assert: 9876543210 printStringHex = '24CB016EA'. self assert: (9876543210 storeStringBase: 10) = '9876543210'. self assert: 9876543210 storeStringHex = '16r24CB016EA'. self assert: (282458553905 printStringBase: 11) = 'A9876543210'. self assert: (282458553905 radix: 11) = 'A9876543210'. self assert: 282458553905 printStringHex = '41C3D77E31'. self assert: (282458553905 storeStringBase: 11) = '11rA9876543210'. self assert: 282458553905 storeStringHex = '16r41C3D77E31'. self assert: (8842413667692 printStringBase: 12) = 'BA9876543210'. self assert: (8842413667692 radix: 12) = 'BA9876543210'. self assert: 8842413667692 printStringHex = '80AC8ECF56C'. self assert: (8842413667692 storeStringBase: 12) = '12rBA9876543210'. self assert: 8842413667692 storeStringHex = '16r80AC8ECF56C'. self assert: (300771807240918 printStringBase: 13) = 'CBA9876543210'. self assert: (300771807240918 radix: 13) = 'CBA9876543210'. self assert: 300771807240918 printStringHex = '1118CE4BAA2D6'. self assert: (300771807240918 storeStringBase: 13) = '13rCBA9876543210'. self assert: 300771807240918 storeStringHex = '16r1118CE4BAA2D6'. self assert: (11046255305880158 printStringBase: 14) = 'DCBA9876543210'. self assert: (11046255305880158 radix: 14) = 'DCBA9876543210'. self assert: 11046255305880158 printStringHex = '273E82BB9AF25E'. self assert: (11046255305880158 storeStringBase: 14) = '14rDCBA9876543210'. self assert: 11046255305880158 storeStringHex = '16r273E82BB9AF25E'. self assert: (435659737878916215 printStringBase: 15) = 'EDCBA9876543210'. self assert: (435659737878916215 radix: 15) = 'EDCBA9876543210'. self assert: 435659737878916215 printStringHex = '60BC6392F366C77'. self assert: (435659737878916215 storeStringBase: 15) = '15rEDCBA9876543210'. self assert: 435659737878916215 storeStringHex = '16r60BC6392F366C77'. self assert: (18364758544493064720 printStringBase: 16) = 'FEDCBA9876543210'. self assert: (18364758544493064720 radix: 16) = 'FEDCBA9876543210'. self assert: 18364758544493064720 printStringHex = 'FEDCBA9876543210'. self assert: (18364758544493064720 storeStringBase: 16) = '16rFEDCBA9876543210'. self assert: 18364758544493064720 storeStringHex = '16rFEDCBA9876543210'. self assert: (824008854613343261192 printStringBase: 17) = 'GFEDCBA9876543210'. self assert: (824008854613343261192 radix: 17) = 'GFEDCBA9876543210'. self assert: 824008854613343261192 printStringHex = '2CAB6B877C1CD2D208'. self assert: (824008854613343261192 storeStringBase: 17) = '17rGFEDCBA9876543210'. self assert: 824008854613343261192 storeStringHex = '16r2CAB6B877C1CD2D208'. self assert: (39210261334551566857170 printStringBase: 18) = 'HGFEDCBA9876543210'. self assert: (39210261334551566857170 radix: 18) = 'HGFEDCBA9876543210'. self assert: 39210261334551566857170 printStringHex = '84D97AFCAE81415B3D2'. self assert: (39210261334551566857170 storeStringBase: 18) = '18rHGFEDCBA9876543210'. self assert: 39210261334551566857170 storeStringHex = '16r84D97AFCAE81415B3D2'. self assert: (1972313422155189164466189 printStringBase: 19) = 'IHGFEDCBA9876543210'. self assert: (1972313422155189164466189 radix: 19) = 'IHGFEDCBA9876543210'. self assert: 1972313422155189164466189 printStringHex = '1A1A75329C5C6FC00600D'. self assert: (1972313422155189164466189 storeStringBase: 19) = '19rIHGFEDCBA9876543210'. self assert: 1972313422155189164466189 storeStringHex = '16r1A1A75329C5C6FC00600D'. self assert: (104567135734072022160664820 printStringBase: 20) = 'JIHGFEDCBA9876543210'. self assert: (104567135734072022160664820 radix: 20) = 'JIHGFEDCBA9876543210'. self assert: 104567135734072022160664820 printStringHex = '567EF3C9636D242A8C68F4'. self assert: (104567135734072022160664820 storeStringBase: 20) = '20rJIHGFEDCBA9876543210'. self assert: 104567135734072022160664820 storeStringHex = '16r567EF3C9636D242A8C68F4'. self assert: (5827980550840017565077671610 printStringBase: 21) = 'KJIHGFEDCBA9876543210'. self assert: (5827980550840017565077671610 radix: 21) = 'KJIHGFEDCBA9876543210'. self assert: 5827980550840017565077671610 printStringHex = '12D4CAE2B8A09BCFDBE30EBA'. self assert: (5827980550840017565077671610 storeStringBase: 21) = '21rKJIHGFEDCBA9876543210'. self assert: 5827980550840017565077671610 storeStringHex = '16r12D4CAE2B8A09BCFDBE30EBA'. self assert: (340653664490377789692799452102 printStringBase: 22) = 'LKJIHGFEDCBA9876543210'. self assert: (340653664490377789692799452102 radix: 22) = 'LKJIHGFEDCBA9876543210'. self assert: 340653664490377789692799452102 printStringHex = '44CB61B5B47E1A5D8F88583C6'. self assert: (340653664490377789692799452102 storeStringBase: 22) = '22rLKJIHGFEDCBA9876543210'. self assert: 340653664490377789692799452102 storeStringHex = '16r44CB61B5B47E1A5D8F88583C6'. self assert: (20837326537038308910317109288851 printStringBase: 23) = 'MLKJIHGFEDCBA9876543210'. self assert: (20837326537038308910317109288851 radix: 23) = 'MLKJIHGFEDCBA9876543210'. self assert: 20837326537038308910317109288851 printStringHex = '1070108876456E0EF115B389F93'. self assert: (20837326537038308910317109288851 storeStringBase: 23) = '23rMLKJIHGFEDCBA9876543210'. self assert: 20837326537038308910317109288851 storeStringHex = '16r1070108876456E0EF115B389F93'. self assert: (1331214537196502869015340298036888 printStringBase: 24) = 'NMLKJIHGFEDCBA9876543210'. self assert: (1331214537196502869015340298036888 radix: 24) = 'NMLKJIHGFEDCBA9876543210'. self assert: 1331214537196502869015340298036888 printStringHex = '41A24A285154B026B6ED206C6698'. self assert: (1331214537196502869015340298036888 storeStringBase: 24) = '24rNMLKJIHGFEDCBA9876543210'. self assert: 1331214537196502869015340298036888 storeStringHex = '16r41A24A285154B026B6ED206C6698'. self assert: (88663644327703473714387251271141900 printStringBase: 25) = 'ONMLKJIHGFEDCBA9876543210'. self assert: (88663644327703473714387251271141900 radix: 25) = 'ONMLKJIHGFEDCBA9876543210'. self assert: 88663644327703473714387251271141900 printStringHex = '111374860A2C6CEBE5999630398A0C'. self assert: (88663644327703473714387251271141900 storeStringBase: 25) = '25rONMLKJIHGFEDCBA9876543210'. self assert: 88663644327703473714387251271141900 storeStringHex = '16r111374860A2C6CEBE5999630398A0C'. self assert: (6146269788878825859099399609538763450 printStringBase: 26) = 'PONMLKJIHGFEDCBA9876543210'. self assert: (6146269788878825859099399609538763450 radix: 26) = 'PONMLKJIHGFEDCBA9876543210'. self assert: 6146269788878825859099399609538763450 printStringHex = '49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (6146269788878825859099399609538763450 storeStringBase: 26) = '26rPONMLKJIHGFEDCBA9876543210'. self assert: 6146269788878825859099399609538763450 storeStringHex = '16r49FBA7F30B0F48BD14E6A99BD8ADABA'. self assert: (442770531899482980347734468443677777577 printStringBase: 27) = 'QPONMLKJIHGFEDCBA9876543210'. self assert: (442770531899482980347734468443677777577 radix: 27) = 'QPONMLKJIHGFEDCBA9876543210'. self assert: 442770531899482980347734468443677777577 printStringHex = '14D1A80A997343640C1145A073731DEA9'. self assert: (442770531899482980347734468443677777577 storeStringBase: 27) = '27rQPONMLKJIHGFEDCBA9876543210'. self assert: 442770531899482980347734468443677777577 storeStringHex = '16r14D1A80A997343640C1145A073731DEA9'. self assert: (33100056003358651440264672384704297711484 printStringBase: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. self assert: (33100056003358651440264672384704297711484 radix: 28) = 'RQPONMLKJIHGFEDCBA9876543210'. self assert: 33100056003358651440264672384704297711484 printStringHex = '6145B6E6DACFA25D0E936F51D25932377C'. self assert: (33100056003358651440264672384704297711484 storeStringBase: 28) = '28rRQPONMLKJIHGFEDCBA9876543210'. self assert: 33100056003358651440264672384704297711484 storeStringHex = '16r6145B6E6DACFA25D0E936F51D25932377C'. self assert: (2564411043271974895869785066497940850811934 printStringBase: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. self assert: (2564411043271974895869785066497940850811934 radix: 29) = 'SRQPONMLKJIHGFEDCBA9876543210'. self assert: 2564411043271974895869785066497940850811934 printStringHex = '1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (2564411043271974895869785066497940850811934 storeStringBase: 29) = '29rSRQPONMLKJIHGFEDCBA9876543210'. self assert: 2564411043271974895869785066497940850811934 storeStringHex = '16r1D702071CBA4A1597D4DD37E95EFAC79241E'. self assert: (205646315052919334126040428061831153388822830 printStringBase: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. self assert: (205646315052919334126040428061831153388822830 radix: 30) = 'TSRQPONMLKJIHGFEDCBA9876543210'. self assert: 205646315052919334126040428061831153388822830 printStringHex = '938B4343B54B550989989D02998718FFB212E'. self assert: (205646315052919334126040428061831153388822830 storeStringBase: 30) = '30rTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 205646315052919334126040428061831153388822830 storeStringHex = '16r938B4343B54B550989989D02998718FFB212E'. self assert: (17050208381689099029767742314582582184093573615 printStringBase: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (17050208381689099029767742314582582184093573615 radix: 31) = 'UTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 17050208381689099029767742314582582184093573615 printStringHex = '2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (17050208381689099029767742314582582184093573615 storeStringBase: 31) = '31rUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 17050208381689099029767742314582582184093573615 storeStringHex = '16r2FC8ECB1521BA16D24A69E976D53873E2C661EF'. self assert: (1459980823972598128486511383358617792788444579872 printStringBase: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (1459980823972598128486511383358617792788444579872 radix: 32) = 'VUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1459980823972598128486511383358617792788444579872 printStringHex = 'FFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (1459980823972598128486511383358617792788444579872 storeStringBase: 32) = '32rVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1459980823972598128486511383358617792788444579872 storeStringHex = '16rFFBBCDEB38BDAB49CA307B9AC5A928398A418820'. self assert: (128983956064237823710866404905431464703849549412368 printStringBase: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (128983956064237823710866404905431464703849549412368 radix: 33) = 'WVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 128983956064237823710866404905431464703849549412368 printStringHex = '584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (128983956064237823710866404905431464703849549412368 storeStringBase: 33) = '33rWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 128983956064237823710866404905431464703849549412368 storeStringHex = '16r584120A0328DE272AB055A8AA003CE4A559F223810'. self assert: (11745843093701610854378775891116314824081102660800418 printStringBase: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (11745843093701610854378775891116314824081102660800418 radix: 34) = 'XWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 11745843093701610854378775891116314824081102660800418 printStringHex = '1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (11745843093701610854378775891116314824081102660800418 storeStringBase: 34) = '34rXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 11745843093701610854378775891116314824081102660800418 storeStringHex = '16r1F64D4FC76000F7B92CF0CD5D0F350139AB9F25D8FA2'. self assert: (1101553773143634726491620528194292510495517905608180485 printStringBase: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (1101553773143634726491620528194292510495517905608180485 radix: 35) = 'YXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1101553773143634726491620528194292510495517905608180485 printStringHex = 'B8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (1101553773143634726491620528194292510495517905608180485 storeStringBase: 35) = '35rYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 1101553773143634726491620528194292510495517905608180485 storeStringHex = '16rB8031AD55AD1FAA89E07A271CA1ED2F420415D1570305'. self assert: (106300512100105327644605138221229898724869759421181854980 printStringBase: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: (106300512100105327644605138221229898724869759421181854980 radix: 36) = 'ZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 106300512100105327644605138221229898724869759421181854980 printStringHex = '455D441E55A37239AB4C303189576071AF5578FFCA80504'. self assert: (106300512100105327644605138221229898724869759421181854980 storeStringBase: 36) = '36rZYXWVUTSRQPONMLKJIHGFEDCBA9876543210'. self assert: 106300512100105327644605138221229898724869759421181854980 storeStringHex = '16r455D441E55A37239AB4C303189576071AF5578FFCA80504'.! ! !IntegerTest methodsFor: 'testing - printing' stamp: 'laza 3/30/2004 09:23'! testRomanPrinting self assert: 0 printStringRoman = ''. "No symbol for zero" self assert: 1 printStringRoman = 'I'. self assert: 2 printStringRoman = 'II'. self assert: 3 printStringRoman = 'III'. self assert: 4 printStringRoman = 'IV'. self assert: 5 printStringRoman = 'V'. self assert: 6 printStringRoman = 'VI'. self assert: 7 printStringRoman = 'VII'. self assert: 8 printStringRoman = 'VIII'. self assert: 9 printStringRoman = 'IX'. self assert: 10 printStringRoman = 'X'. self assert: 23 printStringRoman = 'XXIII'. self assert: 36 printStringRoman = 'XXXVI'. self assert: 49 printStringRoman = 'XLIX'. self assert: 62 printStringRoman = 'LXII'. self assert: 75 printStringRoman = 'LXXV'. self assert: 88 printStringRoman = 'LXXXVIII'. self assert: 99 printStringRoman = 'XCIX'. self assert: 100 printStringRoman = 'C'. self assert: 101 printStringRoman = 'CI'. self assert: 196 printStringRoman = 'CXCVI'. self assert: 197 printStringRoman = 'CXCVII'. self assert: 198 printStringRoman = 'CXCVIII'. self assert: 293 printStringRoman = 'CCXCIII'. self assert: 294 printStringRoman = 'CCXCIV'. self assert: 295 printStringRoman = 'CCXCV'. self assert: 390 printStringRoman = 'CCCXC'. self assert: 391 printStringRoman = 'CCCXCI'. self assert: 392 printStringRoman = 'CCCXCII'. self assert: 487 printStringRoman = 'CDLXXXVII'. self assert: 488 printStringRoman = 'CDLXXXVIII'. self assert: 489 printStringRoman = 'CDLXXXIX'. self assert: 584 printStringRoman = 'DLXXXIV'. self assert: 585 printStringRoman = 'DLXXXV'. self assert: 586 printStringRoman = 'DLXXXVI'. self assert: 681 printStringRoman = 'DCLXXXI'. self assert: 682 printStringRoman = 'DCLXXXII'. self assert: 683 printStringRoman = 'DCLXXXIII'. self assert: 778 printStringRoman = 'DCCLXXVIII'. self assert: 779 printStringRoman = 'DCCLXXIX'. self assert: 780 printStringRoman = 'DCCLXXX'. self assert: 875 printStringRoman = 'DCCCLXXV'. self assert: 876 printStringRoman = 'DCCCLXXVI'. self assert: 877 printStringRoman = 'DCCCLXXVII'. self assert: 972 printStringRoman = 'CMLXXII'. self assert: 973 printStringRoman = 'CMLXXIII'. self assert: 974 printStringRoman = 'CMLXXIV'. self assert: 1069 printStringRoman = 'MLXIX'. self assert: 1070 printStringRoman = 'MLXX'. self assert: 1071 printStringRoman = 'MLXXI'. self assert: 1166 printStringRoman = 'MCLXVI'. self assert: 1167 printStringRoman = 'MCLXVII'. self assert: 1168 printStringRoman = 'MCLXVIII'. self assert: 1263 printStringRoman = 'MCCLXIII'. self assert: 1264 printStringRoman = 'MCCLXIV'. self assert: 1265 printStringRoman = 'MCCLXV'. self assert: 1360 printStringRoman = 'MCCCLX'. self assert: 1361 printStringRoman = 'MCCCLXI'. self assert: 1362 printStringRoman = 'MCCCLXII'. self assert: 1457 printStringRoman = 'MCDLVII'. self assert: 1458 printStringRoman = 'MCDLVIII'. self assert: 1459 printStringRoman = 'MCDLIX'. self assert: 1554 printStringRoman = 'MDLIV'. self assert: 1555 printStringRoman = 'MDLV'. self assert: 1556 printStringRoman = 'MDLVI'. self assert: 1651 printStringRoman = 'MDCLI'. self assert: 1652 printStringRoman = 'MDCLII'. self assert: 1653 printStringRoman = 'MDCLIII'. self assert: 1748 printStringRoman = 'MDCCXLVIII'. self assert: 1749 printStringRoman = 'MDCCXLIX'. self assert: 1750 printStringRoman = 'MDCCL'. self assert: 1845 printStringRoman = 'MDCCCXLV'. self assert: 1846 printStringRoman = 'MDCCCXLVI'. self assert: 1847 printStringRoman = 'MDCCCXLVII'. self assert: 1942 printStringRoman = 'MCMXLII'. self assert: 1943 printStringRoman = 'MCMXLIII'. self assert: 1944 printStringRoman = 'MCMXLIV'. self assert: 2004 printStringRoman = 'MMIV'. self assert: -1 printStringRoman = '-I'. self assert: -2 printStringRoman = '-II'. self assert: -3 printStringRoman = '-III'. self assert: -4 printStringRoman = '-IV'. self assert: -5 printStringRoman = '-V'. self assert: -6 printStringRoman = '-VI'. self assert: -7 printStringRoman = '-VII'. self assert: -8 printStringRoman = '-VIII'. self assert: -9 printStringRoman = '-IX'. self assert: -10 printStringRoman = '-X'. ! ! !InterimSoundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !InterimSoundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0 g: 0.8 b: 0.6! ! !InterimSoundMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:57'! initialize "initialize the state of the receiver" super initialize. "" self extent: 30 @ 30. self addGraphic. sound _ PluckedSound pitch: 880.0 dur: 2.0 loudness: 0.5! ! !InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 11/29/2003 17:35'! addButtons | marginPt i sz data images pageNumber f m b1 b2 dot arrowWidth arrowCenter vertices arrowHeight nameMorph sizeRatio controlsColor | sizeRatio _ self sizeRatio. controlsColor _ Color orange lighter. self changeNoLayout. self hResizing: #rigid. self vResizing: #rigid. marginPt _ (4 @ 4 * sizeRatio) rounded.. i _ self currentIndex. sz _ self myThumbnailSize. arrowWidth _ (14 * sizeRatio) rounded. arrowHeight _ (14 * sizeRatio) rounded. data _ { {i - 1. 'Previous:'. #previousPage. #leftCenter. arrowWidth. 'Prev'}. {i + 1. 'Next:'. #nextPage. #rightCenter. arrowWidth negated. 'Next'} }. images _ data collect: [ :tuple | pageNumber _ tuple first. (pageNumber between: 1 and: listOfPages size) ifTrue: [ f _ self makeThumbnailForPageNumber: pageNumber scaledToSize: sz default: tuple sixth. f _ f deepCopy. "we're going to mess it up" arrowCenter _ f boundingBox perform: tuple fourth. vertices _ { arrowCenter + (tuple fifth @ arrowHeight negated). arrowCenter + (tuple fifth @ arrowHeight). arrowCenter. }. f getCanvas drawPolygon: vertices color: controlsColor borderWidth: 0 borderColor: Color transparent. m _ ImageMorph new image: f. m setBalloonText: tuple second translated,' ',(listOfPages at: pageNumber) first. m addMouseUpActionWith: ( MessageSend receiver: self selector: tuple third ). ] ifFalse: [ f _ (Form extent: sz depth: 16) fillColor: Color lightGray. m _ ImageMorph new image: f. ]. m ]. b1 _ images first. b2 _ images second. dot _ EllipseMorph new extent: (18@18 * sizeRatio) rounded; color: controlsColor; borderWidth: 0. self addMorph: (b1 position: self position + marginPt). self addMorph: (b2 position: b1 topRight + (marginPt x @ 0)). self extent: (b1 bottomRight max: b2 bottomRight) - self position + marginPt. self addMorph: dot. dot align: dot center with: b1 bounds rightCenter + ((marginPt x @ 0) // 2). dot setBalloonText: threadName,' more commands'. dot on: #mouseDown send: #moreCommands to: self. self fullBounds. self addMorph: (nameMorph _ SquishedNameMorph new). nameMorph target: self getSelector: #threadName setSelector: nil; color: Color transparent; width: self width; height: (15 * sizeRatio) rounded; align: nameMorph bottomLeft with: self bottomLeft. ! ! !InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 10/26/2003 19:06'! defaultColor "answer the default color/fill style for the receiver" ^(Color r: 0.27 g: 0.634 b: 0.365) alpha: 0.5! ! !InternalThreadNavigationMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 15:30'! ensureSuitableDefaults listOfPages ifNil: [ listOfPages _ Project allMorphicProjects collect: [ :each | {each name}]. threadName _ 'all (default)' translated. self class know: listOfPages as: threadName. ]. currentIndex ifNil: [currentIndex _ 0]. ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/3/2004 16:58'! destroyThread "Manually destroy the thread" (self confirm: ('Destroy thread <{1}> ?' translated format:{threadName})) ifFalse: [^ self]. self class knownThreads removeKey: threadName ifAbsent: []. self setProperty: #moribund toValue: true. "In case pointed to in some other project" ActiveWorld keyboardNavigationHandler == self ifTrue: [self stopKeyboardNavigation]. self delete! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/4/2001 11:41'! editThisThread | sorter | sorter _ ProjectSorterMorph new. sorter navigator: self listOfPages: listOfPages. self currentWorld addMorphFront: sorter. sorter align: sorter center with: self currentWorld center. self delete. ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 8/15/2001 12:00'! insertNewProject | newProj | [newProj _ Project newMorphicOn: nil.] on: ProjectViewOpenNotification do: [ :ex | ex resume: false]. EToyProjectDetailsMorph getFullInfoFor: newProj ifValid: [self insertNewProjectActionFor: newProj] expandedFormat: false. ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 8/15/2001 12:00'! insertNewProjectActionFor: newProj | me | me _ CurrentProjectRefactoring currentProjectName. listOfPages withIndexDo: [ :each :index | each first = me ifTrue: [ listOfPages add: {newProj name} afterIndex: index. ^self switchToThread: threadName. ]. ]. listOfPages add: {newProj name} afterIndex: listOfPages size. ^self switchToThread: threadName ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 9/19/2003 15:33'! jumpWithinThread | aMenu me weHaveOthers myIndex | me _ CurrentProjectRefactoring currentProjectName. aMenu _ MenuMorph new defaultTarget: self. weHaveOthers _ false. myIndex _ self currentIndex. listOfPages withIndexDo: [ :each :index | index = myIndex ifTrue: [ aMenu add: 'you are here' translated action: #yourself. aMenu lastSubmorph color: Color red. ] ifFalse: [ weHaveOthers _ true. aMenu add: ('jump to <{1}>' translated format:{each first}) selector: #jumpToIndex: argument: index. myIndex = (index - 1) ifTrue: [ aMenu lastSubmorph color: Color blue ]. myIndex = (index + 1) ifTrue: [ aMenu lastSubmorph color: Color orange ]. ]. ]. weHaveOthers ifFalse: [^self inform: 'This is the only project in this thread' translated]. aMenu popUpEvent: self world primaryHand lastEvent in: self world! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 4/4/2004 21:33'! moreCommands "Put up a menu of options" | allThreads aMenu others target | allThreads _ self class knownThreads. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'navigation' translated. aMenu addStayUpItem. self flag: #deferred. "Probably don't want that stay-up item, not least because the navigation-keystroke stuff is not dynamically handled" others _ (allThreads keys reject: [ :each | each = threadName]) asSortedCollection. others do: [ :each | aMenu add: ('switch to <{1}>' translated format:{each}) selector: #switchToThread: argument: each]. aMenu addList: { {'switch to recent projects' translated. #getRecentThread}. #-. {'create a new thread' translated. #threadOfNoProjects}. {'edit this thread' translated. #editThisThread}. {'create thread of all projects' translated. #threadOfAllProjects}. #-. {'First project in thread' translated. #firstPage}. {'Last project in thread' translated. #lastPage}}. (target _ self currentIndex + 2) > listOfPages size ifFalse: [aMenu add: ('skip over next project ({1})' translated format:{(listOfPages at: target - 1) first}) action: #skipOverNext]. aMenu addList: { {'jump within this thread' translated. #jumpWithinThread}. {'insert new project' translated. #insertNewProject}. #-. {'simply close this navigator' translated. #delete}. {'destroy this thread' translated. #destroyThread}. #-}. (ActiveWorld keyboardNavigationHandler == self) ifFalse: [aMenu add: 'start keyboard navigation with this thread' translated action: #startKeyboardNavigation] ifTrue: [aMenu add: 'stop keyboard navigation with this thread' translated action: #stopKeyboardNavigation]. aMenu popUpInWorld! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'dgd 11/29/2003 17:36'! myThumbnailSize ^ (52 @ 39 * self sizeRatio) rounded! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 6/1/2001 13:37'! positionAppropriately | others otherRects overlaps | (self ownerThatIsA: HandMorph) ifNotNil: [^self]. others _ self world submorphs select: [ :each | each ~~ self and: [each isKindOf: self class]]. otherRects _ others collect: [ :each | each bounds]. self align: self fullBounds bottomRight with: self world bottomRight. self setProperty: #previousWorldBounds toValue: self world bounds. [ overlaps _ false. otherRects do: [ :r | (r intersects: bounds) ifTrue: [overlaps _ true. self bottom: r top]. ]. self top < self world top ifTrue: [ self bottom: self world bottom. self right: self left - 1. ]. overlaps ] whileTrue.! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'nb 6/17/2003 12:25'! skipOverNext | target | (target _ self currentIndex + 2) > listOfPages size ifTrue: [^Beeper beep]. currentIndex _ target. self loadPageWithProgress. ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/18/2003 23:12'! startKeyboardNavigation "Tell the active world to starting navigating via desktop keyboard navigation via me" ActiveWorld keyboardNavigationHandler: self! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'sw 3/18/2003 23:09'! stopKeyboardNavigation "Cease navigating via the receiver in response to desktop keystrokes" ActiveWorld removeProperty: #keyboardNavigationHandler! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/24/2001 13:15'! threadName: aString index: anInteger threadName _ aString. preferredIndex _ anInteger. self currentIndex.! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/24/2001 13:15'! threadOfAllProjects | nameList nav | nameList _ Project allMorphicProjects collect: [ :each | {each name}]. nav _ self class basicNew. nav listOfPages: nameList; threadName: '' index: nil; initialize. nav editThisThread. ! ! !InternalThreadNavigationMorph methodsFor: 'navigation' stamp: 'RAA 2/24/2001 13:15'! threadOfNoProjects | nameList nav | nameList _ { {CurrentProjectRefactoring currentProjectName} }. nav _ self class basicNew. nav listOfPages: nameList; threadName: '' index: nil; initialize. nav editThisThread. ! ! !InternalThreadNavigationMorph methodsFor: 'sorting' stamp: 'dgd 9/19/2003 15:27'! acceptSortedContentsFrom: aHolder "Update my page list from the given page sorter." | nameOfThisProject cachedData proj | threadName isEmpty ifTrue: [threadName _ 'I need a name' translated]. threadName _ FillInTheBlank request: 'Name this thread.' translated initialAnswer: threadName. threadName isEmptyOrNil ifTrue: [^self]. listOfPages _ OrderedCollection new. aHolder submorphs doWithIndex: [:m :i | (nameOfThisProject _ m valueOfProperty: #nameOfThisProject) ifNotNil: [ cachedData _ {nameOfThisProject}. proj _ Project named: nameOfThisProject. (proj isNil or: [proj thumbnail isNil]) ifFalse: [ cachedData _ cachedData, {proj thumbnail scaledToSize: self myThumbnailSize}. ]. listOfPages add: cachedData. ]. ]. self class know: listOfPages as: threadName. self removeAllMorphs; addButtons. self world ifNil: [ self openInWorld; positionAppropriately. ]. ! ! !InternalThreadNavigationMorph methodsFor: 'sorting' stamp: 'RAA 2/4/2001 09:38'! makeThumbnailForPageNumber: pageNumber scaledToSize: sz default: aString | cachedData proj tn label | cachedData _ listOfPages at: pageNumber. proj _ Project named: cachedData first. (proj isNil or: [proj thumbnail isNil]) ifTrue: [ cachedData size >= 2 ifTrue: [^cachedData second]. tn _ Form extent: sz depth: 8. tn fillColor: Color veryLightGray. label _ (StringMorph contents: aString) imageForm. label displayOn: tn at: tn center - (label extent // 2) rule: Form paint. ^tn ]. tn _ proj thumbnail scaledToSize: sz. cachedData size < 2 ifTrue: [ cachedData _ cachedData,#(0). listOfPages at: pageNumber put: cachedData. ]. cachedData at: 2 put: tn. ^tn ! ! !InternalThreadNavigationMorph methodsFor: 'stepping' stamp: 'RAA 6/1/2001 13:36'! step super step. (self valueOfProperty: #previousWorldBounds) = self world bounds ifFalse: [ self positionAppropriately. ]. self class knownThreads at: threadName ifPresent: [ :known | known == listOfPages ifFalse: [ listOfPages _ known. self removeAllMorphs. self addButtons. ]. ]. ! ! !InternalThreadNavigationMorph methodsFor: 'piano rolls' stamp: 'md 10/22/2003 15:25'! triggerActionFromPianoRoll | proj | WorldState addDeferredUIMessage: [self currentIndex >= listOfPages size ifTrue: [Beeper beep] ifFalse: [currentIndex := self currentIndex + 1. proj := Project named: ((listOfPages at: currentIndex) first). proj world setProperty: #letTheMusicPlay toValue: true. proj enter]]! ! !InternalThreadNavigationMorph methodsFor: 'private' stamp: 'dgd 10/26/2003 19:37'! currentIndex | currentName | currentName _ CurrentProjectRefactoring currentProjectName. listOfPages withIndexDo: [ :each :index | (each first = currentName and: [preferredIndex = index]) ifTrue: [^currentIndex _ index] ]. listOfPages withIndexDo: [ :each :index | each first = currentName ifTrue: [^currentIndex _ index] ]. currentIndex isNil ifTrue: [^ 1]. ^ currentIndex min: listOfPages size ! ! !InternalThreadNavigationMorph methodsFor: 'private' stamp: 'sw 3/3/2004 17:03'! loadPageWithProgress "Load the desired page, showing a progress indicator as we go" | projectInfo projectName beSpaceHandler | projectInfo _ listOfPages at: currentIndex. projectName _ projectInfo first. loadedProject _ Project named: projectName. self class know: listOfPages as: threadName. beSpaceHandler _ (ActiveWorld keyboardNavigationHandler == self). WorldState addDeferredUIMessage: [InternalThreadNavigationMorph openThreadNamed: threadName atIndex: currentIndex beKeyboardHandler: beSpaceHandler] fixTemps. loadedProject ifNil: [ ComplexProgressIndicator new targetMorph: self; historyCategory: 'project loading' translated; withProgressDo: [ [ loadedProject _ CurrentProjectRefactoring currentFromMyServerLoad: projectName ] on: ProjectViewOpenNotification do: [ :ex | ex resume: false] "we probably don't want a project view morph in this case" ]. ]. loadedProject ifNil: [ ^self inform: 'I cannot find that project' translated ]. self delete. loadedProject enter. ! ! !InternalThreadNavigationMorph methodsFor: 'accessing' stamp: 'dgd 11/29/2003 17:35'! sizeRatio "answer the size ratio for the receiver" ^ Preferences standardMenuFont height / 12! ! !InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:06'! cacheThumbnailFor: aProject | form | CachedThumbnails ifNil: [CachedThumbnails _ Dictionary new]. CachedThumbnails at: aProject name put: (form _ self sorterFormForProject: aProject sized: nil). ^form ! ! !InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:09'! clearThumbnailCache CachedThumbnails _ nil! ! !InternalThreadNavigationMorph class methodsFor: 'thumbnails' stamp: 'RAA 5/10/2001 17:07'! getThumbnailFor: aProject CachedThumbnails ifNil: [CachedThumbnails _ Dictionary new]. ^CachedThumbnails at: aProject name ifAbsentPut: [self sorterFormForProject: aProject sized: nil]! ! !InternalThreadNavigationMorph class methodsFor: 'parts bin' stamp: 'sw 8/19/2001 21:15'! descriptionForPartsBin ^ self partName: 'ThreadNavigator' categories: #('Navigation') documentation: 'A tool that lets you navigate through a thread of projects.'! ! !InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'RAA 2/24/2001 13:10'! openThreadNamed: nameOfThread atIndex: anInteger | coll nav | coll _ self knownThreads at: nameOfThread ifAbsent: [^self]. nav _ World submorphThat: [ :each | (each isKindOf: self) and: [each threadName = nameOfThread]] ifNone: [ nav _ self basicNew. nav listOfPages: coll; threadName: nameOfThread index: anInteger; initialize; openInWorld; positionAppropriately. ^self ]. nav listOfPages: coll; threadName: nameOfThread index: anInteger; removeAllMorphs; addButtons. ! ! !InternalThreadNavigationMorph class methodsFor: 'known threads' stamp: 'sw 3/18/2003 23:12'! openThreadNamed: nameOfThread atIndex: anInteger beKeyboardHandler: aBoolean "Activate the thread of the given name, from the given index; set it up to be navigated via desktop keys if indicated" | coll nav | coll _ self knownThreads at: nameOfThread ifAbsent: [^self]. nav _ World submorphThat: [ :each | (each isKindOf: self) and: [each threadName = nameOfThread]] ifNone: [nav _ self basicNew. nav listOfPages: coll; threadName: nameOfThread index: anInteger; initialize; openInWorld; positionAppropriately. aBoolean ifTrue: [ActiveWorld keyboardNavigationHandler: nav]. ^ self]. nav listOfPages: coll; threadName: nameOfThread index: anInteger; removeAllMorphs; addButtons. aBoolean ifTrue: [ActiveWorld keyboardNavigationHandler: nav] ! ! !InternalThreadNavigationMorph class methodsFor: 'sorter' stamp: 'RAA 5/10/2001 17:04'! sorterFormForProject: aProject sized: ignored ^(ProjectViewMorph on: aProject) imageForm scaledToSize: 80@60. ! ! !InternetConfiguration class methodsFor: 'initialize-release' stamp: 'md 10/27/2004 17:59'! initialize "self initialize" Preferences addPreference: #enableInternetConfig category: #general default: false balloonHelp: 'If true, set http proxy automatically on startUp. Only works on MacOS X for now'. Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'md 10/27/2004 18:00'! shutDown Preferences enableInternetConfig ifTrue: [ (SmalltalkImage current platformName = 'Mac OS') ifTrue: [ HTTPSocket stopUsingProxyServer. ] ]. ! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'md 10/27/2004 18:00'! startUp Preferences enableInternetConfig ifTrue: [ (SmalltalkImage current platformName = 'Mac OS') ifTrue: [ (self getHTTPProxyHost findTokens: ':') ifNotEmpty: [:p | HTTPSocket useProxyServerNamed: p first port: p second asInteger ] ] ]! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useFTPProxy "Return true if UseFTPProxy" "InternetConfiguration useFTPProxy" ^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useGopherProxy "Return true if UseGopherProxy" "InternetConfiguration useGopherProxy" ^(self primitiveGetStringKeyedBy: 'UseGopherProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:41'! useHTTPProxy "Return true if UseHTTPProxy" "InternetConfiguration useHTTPProxy" ^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 9/26/2001 19:42'! usePassiveFTP "Return true if UsePassiveFTP" "InternetConfiguration usePassiveFTP" ^(self primitiveGetStringKeyedBy: 'UsePassiveFTP') = '1' ! ! !InternetConfiguration class methodsFor: 'tests' stamp: 'JMM 10/5/2001 11:23'! useSocks "Return true if UseSocks" "InternetConfiguration useSocks" ^(self primitiveGetStringKeyedBy: 'UseSocks') = '1' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:05'! getArchiePreferred "Return the preferred Archie server" "InternetConfiguration getArchiePreferred" ^self primitiveGetStringKeyedBy: 'ArchiePreferred' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:31'! getDownloadPath "Return the download path" "InternetConfiguration getDownloadPath" ^self primitiveGetStringKeyedBy: 'DownLoadPath' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:07'! getEmail "Return the email address of user" "InternetConfiguration getEmail" ^self primitiveGetStringKeyedBy: 'Email' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:08'! getFTPHost "Return the FTPHost" "InternetConfiguration getFTPHost" ^self primitiveGetStringKeyedBy: 'FTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:09'! getFTPProxyAccount "Return the second level FTP proxy authorisation" "InternetConfiguration getFTPProxyAccount" ^self primitiveGetStringKeyedBy: 'FTPProxyAccount' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:00'! getFTPProxyHost "Return the FTP proxy host" "InternetConfiguration getFTPProxyHost" ^self primitiveGetStringKeyedBy: 'FTPProxyHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:02'! getFTPProxyPassword "Return the FTP proxy password" "InternetConfiguration getFTPProxyPassword" ^self primitiveGetStringKeyedBy: 'FTPProxyPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! getFTPProxyUser "Return the first level FTP proxy authorisation" "InternetConfiguration getFTPProxyUser" ^self primitiveGetStringKeyedBy: 'FTPProxyUser' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:10'! getFingerHost "Return the default finger server" "InternetConfiguration getFingerHost" ^self primitiveGetStringKeyedBy: 'FingerHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! getGopherHost "Return the default Gopher server" "InternetConfiguration getGopherHost" ^self primitiveGetStringKeyedBy: 'GopherHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:11'! getGopherProxy "Return the Gopher proxy" "InternetConfiguration getGopherProxy" ^self primitiveGetStringKeyedBy: 'GopherProxy' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getHTTPProxyHost "Return the http proxy for this client." "InternetConfiguration getHTTPProxyHost" ^self primitiveGetStringKeyedBy: 'HTTPProxyHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getIRCHost "Return the Internet Relay Chat server" "InternetConfiguration getIRCHost" ^self primitiveGetStringKeyedBy: 'IRCHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:14'! getLDAPSearchbase "Return the LDAP thing" "InternetConfiguration getLDAPSearchbase" ^self primitiveGetStringKeyedBy: 'LDAPSearchbase' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:15'! getLDAPServer "Return the LDAP server" "InternetConfiguration getLDAPServer" ^self primitiveGetStringKeyedBy: 'LDAPServer' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 23:45'! getMacintoshFileTypeAndCreatorFrom: aFileName "Return the application type and application signature for the file for the macintosh file system based on the file ending, the file does not need to exist failure to find a signature based on the file ending, or because of primitive failure turns nil" "InternetConfiguration getMacintoshFileTypeAndCreatorFrom: 'test.jpg'" | string | string _ self primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName. string = '********' ifTrue: [^nil]. ^Array with: (string first: 4) with: (string last: 4) ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:07'! getMailAccount "Return the mail account user@host.domain" "InternetConfiguration getMailAccount" ^self primitiveGetStringKeyedBy: 'MailAccount' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:31'! getMailPassword "Return the mail account Password " "InternetConfiguration getMailPassword " ^self primitiveGetStringKeyedBy: 'MailPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:16'! getNNTPHost "Return the NNTP server" "InternetConfiguration getNNTPHost" ^self primitiveGetStringKeyedBy: 'NNTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! getNTPHost "Return the Network Time Protocol (NTP)" "InternetConfiguration getNTPHost" ^self primitiveGetStringKeyedBy: 'NTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/3/2001 14:04'! getNewsAuthPassword "Return the Password for the authorised news servers" "InternetConfiguration getNewsAuthPassword" ^self primitiveGetStringKeyedBy: 'NewsAuthPassword' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:17'! getNewsAuthUsername "Return the user name for authorised news servers" "InternetConfiguration getNewsAuthUsername" ^self primitiveGetStringKeyedBy: 'NewsAuthUsername' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 10/5/2001 10:54'! getNoProxyDomains "Return a comma seperated string of domains not to proxy" "InternetConfiguration getNoProxyDomains" ^self primitiveGetStringKeyedBy: 'NoProxyDomains' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:36'! getOrganization "Return the Organization" "InternetConfiguration getOrganization" ^self primitiveGetStringKeyedBy: 'Organization' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:37'! getPhHost "Return the PhHost server" "InternetConfiguration getPhHost" ^self primitiveGetStringKeyedBy: 'PhHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 20:04'! getRealName "Return the RealName" "InternetConfiguration getRealName" ^self primitiveGetStringKeyedBy: 'RealName' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! getSMTPHost "Return the SMTP server" "InternetConfiguration getSMTPHost" ^self primitiveGetStringKeyedBy: 'SMTPHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:19'! getSocksHost "Return the Socks server" "InternetConfiguration getSocksHost" ^self primitiveGetStringKeyedBy: 'SocksHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:20'! getTelnetHost "Return the TelnetHost server" "InternetConfiguration getTelnetHost" ^self primitiveGetStringKeyedBy: 'TelnetHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! getWAISGateway "Return the wais gateway" "InternetConfiguration getWAISGateway" ^self primitiveGetStringKeyedBy: 'WAISGateway' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! getWWWHomePage "Return the WWW home page url" "InternetConfiguration getWWWHomePage" ^self primitiveGetStringKeyedBy: 'WWWHomePage' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:23'! getWhoisHost "Return the WhoisHost server" "InternetConfiguration getWhoisHost" ^self primitiveGetStringKeyedBy: 'WhoisHost' ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 23:44'! primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName <primitive: 'primitiveGetMacintoshFileTypeAndCreatorFrom' module: 'InternetConfigPlugin'> ^'********' copy ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 9/26/2001 16:31'! primitiveGetStringKeyedBy: aKey <primitive: 'primitiveGetStringKeyedBy' module: 'InternetConfigPlugin'> ^String new. ! ! !Interval methodsFor: 'accessing' stamp: 'stp 8/19/2000 23:52'! extent "Answer the max - min of the receiver interval." "(10 to: 50) extent" ^stop - start! ! !Interval methodsFor: 'comparing' stamp: 'rhi 8/14/2003 10:08'! = anObject ^ self == anObject ifTrue: [true] ifFalse: [anObject isInterval ifTrue: [start = anObject first and: [step = anObject increment and: [self last = anObject last]]] ifFalse: [super = anObject]]! ! !Interval methodsFor: 'enumerating' stamp: 'dtl 5/31/2003 16:45'! permutationsDo: aBlock "Repeatly value aBlock with a single copy of the receiver. Reorder the copy so that aBlock is presented all (self size factorial) possible permutations." "(1 to: 4) permutationsDo: [:each | Transcript cr; show: each printString]" self asArray permutationsDo: aBlock ! ! !Interval methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ true! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'! + number ^ start + number to: stop + number by: step! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'! - number ^ start - number to: stop - number by: step! ! !Interval class methodsFor: 'instance creation' stamp: 'md 1/14/2004 11:42'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." | newInterval n | (n := aCollection size) <= 1 ifTrue: [ n = 0 ifTrue: [^self from: 1 to: 0]. ^self from: aCollection first to: aCollection last]. newInterval := self from: aCollection first to: aCollection last by: (aCollection last - aCollection first) // (n - 1). aCollection ~= newInterval ifTrue: [self error: 'The argument is not an arithmetic progression']. ^newInterval " Interval newFrom: {1. 2. 3} {33. 5. -23} as: Interval {33. 5. -22} as: Interval (an error) (-4 to: -12 by: -1) as: Interval "! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:13'! testEquals self shouldnt: [ self assert: (3 to: 5) = #(3 4 5). self deny: (3 to: 5) = #(3 5). self deny: (3 to: 5) = #(). self assert: #(3 4 5) = (3 to: 5). self deny: #(3 5) = (3 to: 5). self deny: #() = (3 to: 5). ] raise: MessageNotUnderstood.! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:13'! testEquals2 self assert: (3 to: 5) = #(3 4 5). self deny: (3 to: 5) = #(3 5). self deny: (3 to: 5) = #(). self assert: #(3 4 5) = (3 to: 5). self deny: #(3 5) = (3 to: 5). self deny: #() = (3 to: 5).! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:13'! testEquals3 self assert: (3 to: 5 by: 2) first = (3 to: 6 by: 2) first. self assert: (3 to: 5 by: 2) last = (3 to: 6 by: 2) last. self assert: (3 to: 5 by: 2) = (3 to: 6 by: 2).! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:13'! testEquals4 self assert: (3 to: 5 by: 2) = #(3 5). self deny: (3 to: 5 by: 2) = #(3 4 5). self deny: (3 to: 5 by: 2) = #(). self assert: #(3 5) = (3 to: 5 by: 2). self deny: #(3 4 5) = (3 to: 5 by: 2). self deny: #() = (3 to: 5 by: 2).! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:14'! testEquals5 self assert: (3 to: 5 by: 2) = (Heap withAll: #(3 5)). self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)). self deny: (3 to: 5 by: 2) = Heap new. self assert: (Heap withAll: #(3 5)) = (3 to: 5 by: 2). self deny: (Heap withAll: #(3 4 5)) = (3 to: 5 by: 2). self deny: Heap new = (3 to: 5 by: 2).! ! !IntervalTest methodsFor: 'testing' stamp: 'md 10/12/2003 20:14'! testEquals6 self assert: #() = Heap new. self assert: #(3 5) = (Heap withAll: #(3 5)). self deny: (3 to: 5 by: 2) = (Heap withAll: #(3 4 5)). self deny: (3 to: 5 by: 2) = Heap new. self assert: Heap new = #(). self assert: (Heap withAll: #(3 5)) = #(3 5). self deny: (Heap withAll: #(3 4 5)) = #(3 5). self deny: Heap new = #(3 5).! ! !IntervalTest methodsFor: 'testing' stamp: 'sd 12/23/2001 16:16'! testExtent self assert: (Interval from: 10 to: 100) extent = 90! ! !IntervalTest methodsFor: 'testing'! testInvalid "empty, impossible ranges" self assert: (1 to: 0) = #(). self assert: (1 to: -1) = #(). self assert: (-1 to: -2) = #(). self assert: (1 to: 5 by: -1) = #(). "always contains only start value." self assert: (1 to: 1) = #(1). self assert: (1 to: 5 by: 10) = #(1). self assert: (1 to: 0 by: -2) = #(1). ! ! !IntervalTest methodsFor: 'testing' stamp: 'md 1/14/2004 11:43'! testNewFrom self shouldnt: [ self assert: ( (Interval newFrom: (1 to: 1)) = (1 to: 1)). self assert: ( (Interval newFrom: #(1)) = (1 to: 1)). self assert: ( (Interval newFrom: #()) = ( 1 to: 0)) . ] raise: Error.! ! !IntervalTest methodsFor: 'testing'! testNumericTypes (3 asNumber) to: 5 = #(3 4 5). 3.0 to: 5.0 = #(3.0 4.0 5.0). 3.0 to: 5.0 by: 0.5 = #(3.0 3.5 4.0 4.5 5.0). 3/1 to: 5/1 = #(3 4 5). 1/2 to: 5/2 by: 1/2 = #(1/2 1 3/2 2 5/2).! ! !IntervalTest methodsFor: 'testing' stamp: 'sd 2/21/2004 13:46'! testOtherNewFrom "self run: #testOtherNewFrom" self assert: (Interval newFrom: #(1 2 3 )) = (1 to: 3). self assert: (Interval newFrom: #(33 5 -23 )) = (33 to: -23 by: -28). self should: [(Interval newFrom: #(33 5 -22 ))] raise: Error. self assert: (#(33 5 -23) as: Interval) = (33 to: -23 by: -28). self should: [( #(33 5 -22 ) as: Interval)] raise: Error. self assert: ( (-4 to: -12 by: -1) as: Interval) = (-4 to: -12 by: -1). self assert: ( Interval newFrom: (1 to: 1)) = (1 to: 1). self assert: ( Interval newFrom: (1 to: 0)) = (1 to: 0). self assert: (#(1) as: Interval) = (1 to: 1). self assert: (#() as: Interval) = (1 to: 0).! ! !IntervalTest methodsFor: 'testing' stamp: 'md 6/6/2003 15:02'! testPermutationsDo | i oc | i _ (1.234 to: 4.234). oc _ OrderedCollection new. i permutationsDo: [:e | oc add: e]. self assert: (oc size == i size factorial)! ! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:44'! pathName ^pathName! ! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:45'! pathName: badPathName pathName _ badPathName! ! !InvalidDirectoryError methodsFor: 'exceptionDescription' stamp: 'ar 5/30/2001 20:49'! defaultAction "Return an empty list as the default action of signaling the occurance of an invalid directory." ^#()! ! !InvalidDirectoryError class methodsFor: 'exceptionInstantiator' stamp: 'ar 5/30/2001 20:49'! pathName: badPathName ^self new pathName: badPathName! ! !InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15' prior: 0! Signals if an operation on a Socket found it in a state invalid for that operation. ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'! aaaREADMEaboutPrimitives "most of the Islands tweaks allow primitive methods to be located in places other than class Object. Thus they are copied here for testing." ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'! classOf: anObject <primitive: 111> ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:16'! instVarOf: anObject at: index <primitive: 73> self primitiveFailed ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:17'! instVarOf: anObject at: index put: anotherObject <primitive: 74> self primitiveFailed ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'! nextInstanceAfter: anObject <primitive: 78> ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:18'! nextObjectAfter: anObject <primitive: 139> ! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:21'! replaceIn: replacee from: start to: stop with: replacer startingAt: replStart <primitive: 105> self primitiveFailed! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:19'! someInstanceOf: aClass <primitive: 77> self primitiveFailed! ! !IslandVMTweaksTestCase methodsFor: 'primitives' stamp: 'ls 7/10/2003 10:20'! someObject <primitive: 138> self primitiveFailed! ! !IslandVMTweaksTestCase methodsFor: 'miscellaneous' stamp: 'ls 7/10/2003 17:42'! returnTwelve "this method is tweaked by testFlagInCompiledMethod" ^12! ! !IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 11:03'! testEmptyReplace | array1 array2 | array1 := Array with: 1 with: 2 with: 3 with: 4. array2 := Array with: 5 with: 6 with: 7. self replaceIn: array1 from: 1 to: 0 with: array2 startingAt: 1. self should: [ array1 = #(1 2 3 4) ]. ! ! !IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 18:53'! testFlagInCompiledMethod "this tests that the flag in compiled methods is treated correctly" | method | method := self class compiledMethodAt: #returnTwelve. "turn off the flag" method objectAt: 1 put: (method header bitAnd: (1 << 29) bitInvert). self should: [ method flag not ]. "turn on the flag" method objectAt: 1 put: (method header bitOr: (1 << 29)). self should: [ method flag ]. "try running the method with the flag turned on" self should: [ self returnTwelve = 12 ]. "make sure the flag bit isn't interpreted as a primitive" self should: [ method primitive = 0 ].! ! !IslandVMTweaksTestCase methodsFor: 'testing' stamp: 'ls 7/10/2003 10:38'! testForgivingPrims | aPoint anotherPoint array1 array2 | aPoint := Point x: 5 y: 6. anotherPoint := Point x: 7 y: 8. "make sure there are multiple points floating around" anotherPoint. "stop the compiler complaining about no uses" self should: [ (self classOf: aPoint) = Point ]. self should: [ (self instVarOf: aPoint at: 1) = 5 ]. self instVarOf: aPoint at: 2 put: 10. self should: [ (self instVarOf: aPoint at: 2) = 10 ]. self someObject. self nextObjectAfter: aPoint. self should: [ (self someInstanceOf: Point) class = Point ]. self should: [ (self nextInstanceAfter: aPoint) class = Point ]. array1 := Array with: 1 with: 2 with: 3. array2 := Array with: 4 with: 5 with: 6. self replaceIn: array1 from: 2 to: 3 with: array2 startingAt: 1. self should: [ array1 = #(1 4 5) ]. ! ! !IslandVMTweaksTestCase commentStamp: 'ls 7/10/2003 18:59' prior: 0! Test case for some tweaks to the VM that Islands requires. These tests are largely for documentation; with an un-tweaked VM, the tests mostly still succeed, albeit with possible memory corruption.! !JISX0208 commentStamp: 'yo 10/19/2004 19:52' prior: 0! This class represents the domestic character encoding called JIS X 0208 used for Japanese.! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 09:24'! charAtKuten: anInteger | a b | a _ anInteger \\ 100. b _ anInteger // 100. (a > 94) | (b > 94) ifTrue: [ self error: 'character code is not valid'. ]. ^ MultiCharacter leadingChar: self leadingChar code: ((b - 1) * 94) + a - 1. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:49'! compoundTextSequence ^ CompoundTextSequence. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 16:49'! initialize " self initialize " CompoundTextSequence _ String streamContents: [:s | s nextPut: (Character value: 27). s nextPut: $$. s nextPut: $B ]. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 17:38'! leadingChar ^ 1. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. (state g0Leading ~= self leadingChar) ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: CompoundTextSequence. ]. c1 _ ascii // 94 + 16r21. c2 _ ascii \\ 94 + 16r21. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2). ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/4/2002 22:52'! printingDirection ^ #right. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 11/10/2002 09:09'! stringFromKutenArray: anArray | s | s _ MultiString new: anArray size. 1 to: anArray size do: [:i | s at: i put: (self charAtKuten: (anArray at: i)). ]. ^s. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable jisx0208Table. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 7/21/2004 18:36'! unicodeLeadingChar ^ JapaneseEnvironment leadingChar. ! ! !JISX0208 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading _ char leadingChar. value _ char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value _ value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !JISX0208 class methodsFor: 'accessing - displaying' stamp: 'yo 3/18/2003 11:11'! isBreakableAt: index in: text | prev | index = 1 ifTrue: [^ false]. prev _ text at: index - 1. prev leadingChar ~= 1 ifTrue: [^ true]. ^ false ! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'ar 3/4/2001 01:19'! mcuWidth: mw mcuHeight: mh dctSize: ds mcuWidth _ mw. mcuHeight _ mh. dctSize _ ds. hSampleFactor _ mcuWidth // widthInBlocks. vSampleFactor _ mcuHeight // heightInBlocks! ! !JPEGColorComponent methodsFor: 'sample streaming' stamp: 'ar 3/4/2001 22:16'! nextSample | dx dy blockIndex sampleIndex sample | dx _ currentX // hSampleFactor. dy _ currentY // vSampleFactor. blockIndex _ dy // dctSize * widthInBlocks + (dx // dctSize) + 1. sampleIndex _ dy \\ dctSize * dctSize + (dx \\ dctSize) + 1. sample _ (mcuBlocks at: blockIndex) at: sampleIndex. currentX _ currentX + 1. currentX < (mcuWidth * dctSize) ifFalse: [currentX _ 0. currentY _ currentY + 1]. ^ sample! ! !JPEGColorComponent commentStamp: '<historical>' prior: 0! I represent a single component of color in JPEG YCbCr color space. I can accept a list of blocks in my component from the current MCU, then stream the samples from this block for use in color conversion. I also store the running DC sample value for my component, used by the Huffman decoder. The following layout is fixed for the JPEG primitives to work: currentX <SmallInteger> currentY <SmallInteger> hSampleFactor <SmallInteger> vSampleFactor <SmallInteger> mcuBlocks <Array of: <IntegerArray of: DCTSize2 * Integer>> widthInBlocks <SmallInteger> heightInBlocks <SmallInteger> dctSize <SmallInteger> mcuWidth <SmallInteger> mcuHeight <SmallInteger> priorDCValue <SmallInteger> ! !JPEGMovieFile methodsFor: 'initialization' stamp: 'jm 11/15/2001 08:13'! initialize file _ nil. frameOffsets _ #(). currentFrameIndex _ 1. ! ! !JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/14/2001 14:08'! closeFile "Close my file stream." file ifNotNil: [file close]. ! ! !JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/14/2001 14:13'! fileHandle "Answer my file, or nil if the file is not open." file ifNil: [^ nil]. file closed ifTrue: [^ nil]. ^ file ! ! !JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 11/15/2001 07:59'! fileName "Answer the name of my file." file ifNil: [^ '']. ^ file fullName ! ! !JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 2/11/2002 13:09'! openFile: fileName "For compatability with MPEGFile." self openFileNamed: fileName. ! ! !JPEGMovieFile methodsFor: 'file ops' stamp: 'jm 2/11/2002 13:30'! openFileNamed: fileName "Open the JPEG movie file with the given name." file ifNotNil: [file finalize]. file _ nil. (FileDirectory default fileExists: fileName) ifFalse: [^ self]. file _ (FileStream readOnlyFileNamed: fileName) binary. self readHeader. currentFrameIndex _ 1. ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/20/2001 16:08'! hasVideo "Answer true if I have one or more frames." ^ frameOffsets size > 1 "note: the empty movie still has one frameOffset" ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/14/2001 14:18'! videoDropFrames: skipCount stream: streamIndex "Advance the index of the current frame by the given number of frames." self videoSetFrame: currentFrameIndex + skipCount stream: streamIndex. ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 08:08'! videoFrameHeight: ignored "Answer the height of this movie." ^ movieExtent y ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 07:37'! videoFrameRate: ignored "Answer the frame rate of this movie." ^ frameRate ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 08:08'! videoFrameWidth: ignored "Answer the width of this movie." ^ movieExtent x ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 07:34'! videoFrames: ignored "Answer the number of video frames in this movie." ^ (frameOffsets size - 1) max: 0 ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/14/2001 14:05'! videoGetFrame: ignored "Answer the index of the current frame, or zero if the movie has no frames." ^ currentFrameIndex ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/20/2001 11:02'! videoReadFrameInto: aForm stream: aStream "Read the next frame into the given 16-bit or 32-bit Form." | compressedBytes | compressedBytes _ self bytesForFrame: currentFrameIndex. compressedBytes ifNil: [^ self]. JPEGReadWriter2 new uncompress: compressedBytes into: aForm. currentFrameIndex _ (currentFrameIndex + 1) min: (frameOffsets size - 1). ! ! !JPEGMovieFile methodsFor: 'video' stamp: 'jm 11/15/2001 08:10'! videoSetFrame: newIndex stream: ignored "Set the index of the current frame." currentFrameIndex _ (newIndex asInteger max: 1) min: (frameOffsets size - 1). ! ! !JPEGMovieFile methodsFor: 'audio' stamp: 'jm 11/17/2001 09:49'! audioPlayerForChannel: anInteger "Answer a streaming sound for playing the audio channel with the given index." ((anInteger >= 1) & (anInteger <= soundtrackOffsets size)) ifFalse: [^ nil]. ^ StreamingMonoSound onFileNamed: file fullName headerStart: (soundtrackOffsets at: anInteger) ! ! !JPEGMovieFile methodsFor: 'audio' stamp: 'jm 11/16/2001 17:03'! hasAudio "Answer true if this movie has at least one sound track." ^ soundtrackOffsets size > 0 ! ! !JPEGMovieFile methodsFor: 'private' stamp: 'jm 11/15/2001 08:02'! bytesForFrame: frameIndex "Answer a ByteArray containing the encoded bytes for the frame with the given index. Answer nil if the index is out of range or if my file is not open." frameIndex < 1 ifTrue: [^ nil]. frameIndex >= frameOffsets size ifTrue: [^ nil]. file ifNil: [^ nil]. file closed ifTrue: [file ensureOpen; binary]. file position: (frameOffsets at: frameIndex). ^ file next: (frameOffsets at: frameIndex + 1) - (frameOffsets at: frameIndex) ! ! !JPEGMovieFile methodsFor: 'private' stamp: 'jm 11/16/2001 17:01'! readHeader "Read a JPEG movie header file." "Details: The file structures is: <header, including sequence frame offsets> <sequence of JPEG compressed images> <optional soundtracks>" | tag w h frameOffsetCount soundtrackCount | file position: 0. tag _ (file next: 10) asString. tag = 'JPEG Movie' ifFalse: [self error: 'not a JPEG movie file']. w _ file uint16. h _ file uint16. movieExtent _ w @ h. frameRate _ file uint32 / 10000.0. frameOffsetCount _ file uint32. frameOffsets _ Array new: frameOffsetCount. 1 to: frameOffsetCount do: [:i | frameOffsets at: i put: file uint32]. soundtrackCount _ file uint16. soundtrackOffsets _ Array new: soundtrackCount. 1 to: soundtrackCount do: [:i | soundtrackOffsets at: i put: file uint32]. ! ! !JPEGMovieFile methodsFor: 'private' stamp: 'jm 12/13/2001 19:14'! soundtrackOffsets "Answer the offsets for my soundtracks." ^ soundtrackOffsets ! ! !JPEGMovieFile methodsFor: 'private' stamp: 'jm 11/27/2001 10:23'! testPlay "Performance benchmark. Decompress and display all my frames. Answer the frame rate achieved in frames/second. No sound is played." | frameForm frameCount t | frameForm _ Form extent: movieExtent depth: (Display depth max: 16). frameCount _ self videoFrames: 0. self videoSetFrame: 1 stream: 0. t _ [ frameCount timesRepeat: [ self videoReadFrameInto: frameForm stream: 0. frameForm display]. ] timeToRun. ^ ((1000.0 * frameCount) / t) roundTo: 0.01 ! ! !JPEGMovieFile commentStamp: '<historical>' prior: 0! A JPEG movie file consists of a header followed by a sequence of JPEG-compressed images followed by one or more sound tracks. It responds to a subset of the protocol for MPEGFile so that a JPEG movie can be played by MPEGDisplayMorph as if it were an MPEG movie. ! !JPEGMovieFile class methodsFor: 'testing' stamp: 'jm 11/15/2001 14:56'! isJPEGMovieFile: fileName "Answer true if the file with the given name appears to be a JPEG movie file." | f tag | (FileDirectory default fileExists: fileName) ifFalse: [^ false]. f _ (FileStream readOnlyFileNamed: fileName) binary. tag _ (f next: 10) asString. f close. ^ tag = 'JPEG Movie' ! ! !JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'jm 1/25/2002 20:46'! convertFromFolderOfFramesNamed: folderName toJPEGMovieNamed: jpegFileName frameRate: frameRate quality: quality "Convert a folder of frames into a JPEG movie. The named folder is assumed to contain only image files, all of the same size, and whose alphabetical order (case-insensitive) is the sequence in which they will appear in in the movie. A useful convention is to make the image files end in zero-padded frame numbers, for example 'frame0001.bmp', 'frame0002.bmp', etc. The image files can be any format readable by Form>fromFileNamed:. The movie frame extent is taken from the first frame file." | jpegFile dir fileNames frameCount frameForm frameOffsets | (FileDirectory default directoryExists: folderName) ifFalse: [^ self inform: 'Folder not found: ', folderName]. jpegFile _ (FileStream newFileNamed: jpegFileName) binary. dir _ FileDirectory default on: folderName. fileNames _ self sortedByFrameNumber: dir fileNames. frameCount _ fileNames size. frameForm _ Form fromFileNamed: (dir fullNameFor: fileNames first). "write header" self writeHeaderExtent: frameForm extent frameRate: frameRate frameCount: frameCount soundtrackCount: 0 on: jpegFile. "convert and write frames" frameOffsets _ Array new: frameCount + 1. 1 to: frameCount do: [:i | frameOffsets at: i put: jpegFile position. frameForm _ Form fromFileNamed: (dir fullNameFor: (fileNames at: i)). self writeFrame: frameForm on: jpegFile quality: quality displayFlag: true]. frameOffsets at: (frameCount + 1) put: jpegFile position. self updateFrameOffsets: frameOffsets on: jpegFile. jpegFile close. Display restore. ! ! !JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'jm 12/13/2001 09:38'! convertMPEGFileNamed: mpegFileName toJPEGMovieNamed: jpegFileName quality: quality "Convert the MPEG movie with the given file name into a JPEG movie with the given file name." | mpegFile jpegFile soundtrackCount movieExtent frameOffsets soundTrackOffsets | (FileDirectory default fileExists: mpegFileName) ifFalse: [^ self inform: 'File not found: ', mpegFileName]. (MPEGFile isFileValidMPEG: mpegFileName) ifFalse: [^ self inform: 'Not an MPEG file: ', mpegFileName]. mpegFile _ MPEGFile openFile: mpegFileName. mpegFile fileHandle ifNil: [^ self inform: 'Could not open ', mpegFileName]. jpegFile _ (FileStream newFileNamed: jpegFileName) binary. "write header" soundtrackCount _ mpegFile hasAudio ifTrue: [1] ifFalse: [0]. mpegFile hasVideo ifTrue: [ movieExtent _ (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0). self writeHeaderExtent: movieExtent frameRate: (mpegFile videoFrameRate: 0) frameCount: (mpegFile videoFrames: 0) soundtrackCount: soundtrackCount on: jpegFile] ifFalse: [ self writeHeaderExtent: 0@0 frameRate: 0 frameCount: 0 soundtrackCount: soundtrackCount on: jpegFile]. "convert and write frames" frameOffsets _ self writeFramesFrom: mpegFile on: jpegFile quality: quality. self updateFrameOffsets: frameOffsets on: jpegFile. "convert and write sound tracks" jpegFile position: frameOffsets last. "store sound tracks after the last frame" soundTrackOffsets _ self writeSoundTracksFrom: mpegFile on: jpegFile. self updateSoundtrackOffsets: soundTrackOffsets frameOffsets: frameOffsets on: jpegFile. mpegFile closeFile. jpegFile close. Display restore. ! ! !JPEGMovieFile class methodsFor: 'movie conversion' stamp: 'jm 12/13/2001 09:39'! convertSqueakMovieNamed: squeakMovieFileName toJPEGMovieNamed: jpegFileName quality: quality "Convert the Squeak movie with the given file name into a JPEG movie with the given file name." | sqMovieFile jpegFile w h d frameCount mSecsPerFrame frameForm bytesPerFrame frameOffsets | (FileDirectory default fileExists: squeakMovieFileName) ifFalse: [^ self inform: 'File not found: ', squeakMovieFileName]. sqMovieFile _ (FileStream readOnlyFileNamed: squeakMovieFileName) binary. sqMovieFile ifNil: [^ self inform: 'Could not open ', squeakMovieFileName]. jpegFile _ (FileStream newFileNamed: jpegFileName) binary. sqMovieFile nextInt32. "skip first word" w _ sqMovieFile nextInt32. h _ sqMovieFile nextInt32. d _ sqMovieFile nextInt32. frameCount _ sqMovieFile nextInt32. mSecsPerFrame _ (sqMovieFile nextInt32) / 1000.0. "write header" self writeHeaderExtent: w@h frameRate: (1000.0 / mSecsPerFrame) frameCount: frameCount soundtrackCount: 0 on: jpegFile. "convert and write frames" frameForm _ Form extent: w@h depth: d. bytesPerFrame _ 4 + (frameForm bits size * 4). frameOffsets _ Array new: frameCount + 1. 1 to: frameCount do: [:i | frameOffsets at: i put: jpegFile position. sqMovieFile position: 128 + ((i - 1) * bytesPerFrame) + 4. sqMovieFile next: frameForm bits size into: frameForm bits startingAt: 1. frameForm display. self writeFrame: frameForm on: jpegFile quality: quality displayFlag: false]. frameOffsets at: (frameCount + 1) put: jpegFile position. self updateFrameOffsets: frameOffsets on: jpegFile. sqMovieFile close. jpegFile close. Display restore. ! ! !JPEGMovieFile class methodsFor: 'movie soundtracks' stamp: 'jm 12/13/2001 21:03'! addSoundtrack: soundFileName toJPEGMovieNamed: jpegFileName compressionType: compressionTypeString "Append the given audio file as a soundtrack the given JPEG movie using the given compression type ('none', 'adpcm3', 'adpcm4', 'adpcm5', 'mulaw', or 'gsm')." "Note: While the Squeak JPEG movie format supports multiple soundtracks, the player currently plays only the first soundtrack." | snd jpegFile outFile frameCount newFrameOffsets buf inFile newSoundtrackOffsets oldMovieName | snd _ StreamingMonoSound onFileNamed: soundFileName. jpegFile _ JPEGMovieFile new openFileNamed: jpegFileName. outFile _ (FileStream newFileNamed: 'movie.tmp') binary. frameCount _ jpegFile videoFrames: 0. "write new header" self writeHeaderExtent: ((jpegFile videoFrameWidth: 0)@(jpegFile videoFrameHeight: 0)) frameRate: (jpegFile videoFrameRate: 0) frameCount: frameCount soundtrackCount: (jpegFile soundtrackOffsets size + 1) on: outFile. "copy frames to new file" newFrameOffsets _ Array new: frameCount + 1. 1 to: frameCount do: [:i | newFrameOffsets at: i put: outFile position. buf _ jpegFile bytesForFrame: i. outFile nextPutAll: buf]. newFrameOffsets at: frameCount + 1 put: outFile position. "copy existing soundtracks, if any, to new file" jpegFile soundtrackOffsets size > 0 ifTrue: [ inFile _ jpegFile fileHandle. inFile position: jpegFile soundtrackOffsets first. buf _ ByteArray new: 10000. [inFile atEnd] whileFalse: [ buf _ inFile next: buf size into: buf startingAt: 1. outFile nextPutAll: buf]]. "adjust soundtrack offsets for header size increase and add new one:" newSoundtrackOffsets _ jpegFile soundtrackOffsets collect: [:n | n + 4]. newSoundtrackOffsets _ newSoundtrackOffsets copyWith: outFile position. snd storeSunAudioOn: outFile compressionType: compressionTypeString. "update header:" self updateFrameOffsets: newFrameOffsets on: outFile. self updateSoundtrackOffsets: newSoundtrackOffsets frameOffsets: newFrameOffsets on: outFile. "close files" snd closeFile. jpegFile closeFile. outFile close. "replace the old movie with the new version" oldMovieName _ (jpegFile fileName copyFrom: 1 to: (jpegFile fileName size - 4)), '.old'. FileDirectory default deleteFileNamed: oldMovieName. FileDirectory default rename: jpegFile fileName toBe: oldMovieName. FileDirectory default rename: 'movie.tmp' toBe: jpegFile fileName. ! ! !JPEGMovieFile class methodsFor: 'movie soundtracks' stamp: 'jm 12/13/2001 21:03'! removeSoundtrackFromJPEGMovieNamed: jpegFileName "Remove all soundtracks from the JPEG movie with the given name." | jpegFile outFile frameCount newFrameOffsets buf oldMovieName | jpegFile _ JPEGMovieFile new openFileNamed: jpegFileName. outFile _ (FileStream newFileNamed: 'movie.tmp') binary. frameCount _ jpegFile videoFrames: 0. "write new header" self writeHeaderExtent: ((jpegFile videoFrameWidth: 0)@(jpegFile videoFrameHeight: 0)) frameRate: (jpegFile videoFrameRate: 0) frameCount: frameCount soundtrackCount: 0 on: outFile. "copy frames to new file" newFrameOffsets _ Array new: frameCount + 1. 1 to: frameCount do: [:i | newFrameOffsets at: i put: outFile position. buf _ jpegFile bytesForFrame: i. outFile nextPutAll: buf]. newFrameOffsets at: frameCount + 1 put: outFile position. "update header:" self updateFrameOffsets: newFrameOffsets on: outFile. "close files" jpegFile closeFile. outFile close. "replace the old movie with the new version" oldMovieName _ (jpegFile fileName copyFrom: 1 to: (jpegFile fileName size - 4)), '.old'. FileDirectory default deleteFileNamed: oldMovieName. FileDirectory default rename: jpegFile fileName toBe: oldMovieName. FileDirectory default rename: 'movie.tmp' toBe: jpegFile fileName. ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 1/25/2002 21:08'! extractFrameNumberFrom: aString "Answer the integer frame number from the given file name string. The frame number is assumed to be the last contiguous sequence of digits in the given string. For example, 'take2 005.jpg' is frame 5 of the sequence 'take2'." "Assume: The given string contains at least one digit." | end start | end _ aString size. [(aString at: end) isDigit not] whileTrue: [end _ end - 1]. start _ end. [(start > 1) and: [(aString at: start - 1) isDigit]] whileTrue: [start _ start - 1]. ^ (aString copyFrom: start to: end) asNumber ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 2/3/2002 10:14'! sortedByFrameNumber: fileNames "Sort the given collection of fileNames by frame number. The frame number is the integer value of the last contiguous sequence of digits in the file name. Omit filenames that do not contain at least one digit; this helps filter out extraneous non-frame files such as the invisible 'Icon' file that may be inserted by some file servers." | filtered pairs | "select the file names contain at least one digit" filtered _ fileNames select: [:fn | fn anySatisfy: [:c | c isDigit]]. "make array of number, name pairs" pairs _ filtered asArray collect: [:fn | Array with: (self extractFrameNumberFrom: fn) with: fn]. "sort the pairs, then answer a collection containing the second element of every pair" pairs sort: [:p1 :p2 | p1 first < p2 first]. ^ pairs collect: [:p | p last]. ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/17/2001 08:05'! updateFrameOffsets: frameOffsets on: aBinaryStream "Update the JPEG movie file header on the given stream with the given collection of frame offsets." aBinaryStream position: 22. frameOffsets do: [:offset | aBinaryStream uint32: offset]. ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/17/2001 07:40'! updateSoundtrackOffsets: soundtrackOffsetList frameOffsets: frameOffsets on: aBinaryStream "Update the JPEG movie file header on the given stream with the given sequence of sound track offsets." aBinaryStream position: 22 + (4 * frameOffsets size). aBinaryStream uint16: soundtrackOffsetList size. soundtrackOffsetList do: [:offset | aBinaryStream uint32: offset]. ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/25/2001 14:20'! writeFrame: aForm on: aBinaryStream quality: quality displayFlag: displayFlag "Compress and the given Form on the given stream and answer its offset. If displayFlag is true, show the result of JPEG compression on the display." | offset compressed outForm | offset _ aBinaryStream position. compressed _ JPEGReadWriter2 new compress: aForm quality: quality. displayFlag ifTrue: [ "show decompressed frame" outForm _ (JPEGReadWriter2 on: (ReadStream on: compressed)) nextImage. outForm display]. aBinaryStream nextPutAll: compressed. ^ offset ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/25/2001 14:23'! writeFramesFrom: mpegFile on: aBinaryStream quality: quality "Write the frames of the given MPEG movie on the given stream at the given JPEG quality level. Answer a collection of frame offsets. The size of this collection is one larger than the number of frames; it's final entry is the stream position just after the final frame. The byte count for any frame can thus be computed as the difference between two adjacent offsets." | frameCount frameOffsets frameForm | mpegFile hasVideo ifFalse: [^ Array with: aBinaryStream position]. frameCount _ mpegFile videoFrames: 0. frameOffsets _ OrderedCollection new: frameCount + 1. frameForm _ Form extent: (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0) depth: 32. [(mpegFile videoGetFrame: 0) < (mpegFile videoFrames: 0)] whileTrue: [ frameOffsets addLast: aBinaryStream position. mpegFile videoReadFrameInto: frameForm stream: 0. self writeFrame: frameForm on: aBinaryStream quality: quality displayFlag: true]. frameOffsets addLast: aBinaryStream position. "add final offset" ^ frameOffsets ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/17/2001 08:01'! writeHeaderExtent: movieExtent frameRate: frameRate frameCount: frameCount soundtrackCount: soundtrackCount on: aBinaryStream "Write a header on the given stream for a JPEG movie file with the given specifications. Leave the stream positioned at the start of the first movie frame." | offsetCount | aBinaryStream position: 0. aBinaryStream nextPutAll: ('JPEG Movie') asByteArray. aBinaryStream uint16: movieExtent x. aBinaryStream uint16: movieExtent y. aBinaryStream uint32: (frameRate * 10000) rounded. offsetCount _ frameCount + 1. aBinaryStream uint32: offsetCount. aBinaryStream skip: (offsetCount * 4). "leave room for frame offsets" aBinaryStream uint16: soundtrackCount. aBinaryStream skip: (soundtrackCount * 4). "leave room for sound track offsets" ! ! !JPEGMovieFile class methodsFor: 'movie creation-private' stamp: 'jm 11/25/2001 16:55'! writeSoundTracksFrom: mpegFile on: aBinaryStream "Convert and write the sound tracks from the given MPEG file to given stream. Answer a collection of sound track offsets." "Details: Currently converts at most one sound track; only the left channel of a stereo movie will be converted." | soundtrackCount soundTrackOffsets snd | soundtrackCount _ mpegFile hasAudio ifTrue: [1] ifFalse: [0]. soundTrackOffsets _ Array new: soundtrackCount. 1 to: soundtrackCount do: [:i | soundTrackOffsets at: i put: aBinaryStream position. snd _ mpegFile audioPlayerForChannel: i. snd storeSunAudioOn: aBinaryStream compressionType: 'mulaw'. snd closeFile]. ^ soundTrackOffsets ! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 20:42'! fillBuffer | byte | [bitsInBuffer <= 16] whileTrue:[ byte _ self next. (byte = 16rFF and: [(self peekFor: 16r00) not]) ifTrue: [self position: self position - 1. ^0]. bitBuffer _ (bitBuffer bitShift: 8) bitOr: byte. bitsInBuffer _ bitsInBuffer + 8]. ^ bitsInBuffer! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 18:43'! getBits: requestedBits | value | requestedBits > bitsInBuffer ifTrue:[ self fillBuffer. requestedBits > bitsInBuffer ifTrue:[ self error: 'not enough bits available to decode']]. value _ bitBuffer bitShift: (requestedBits - bitsInBuffer). bitBuffer _ bitBuffer bitAnd: (1 bitShift: (bitsInBuffer - requestedBits)) -1. bitsInBuffer _ bitsInBuffer - requestedBits. ^ value! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:34'! nextByte ^self next asInteger! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:35'! nextBytes: n ^(self next: n) asByteArray! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 17:40'! reset super reset. self resetBitBuffer! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 18:44'! resetBitBuffer bitBuffer _ 0. bitsInBuffer _ 0. ! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 21:06'! buildLookupTable: values counts: counts | min max | min _ max _ nil. 1 to: counts size do:[:i| (counts at: i) = 0 ifFalse:[ min ifNil:[min _ i-1]. max _ i]]. ^self createHuffmanTables: values counts: {0},counts from: min+1 to: max.! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:46'! createHuffmanTables: values counts: counts from: minBits to: maxBits "Create the actual tables" | table tableStart tableSize tableEnd valueIndex tableStack numValues deltaBits maxEntries lastTable lastTableStart tableIndex lastTableIndex | table _ WordArray new: ((4 bitShift: minBits) max: 16). "Create the first entry - this is a dummy. It gives us information about how many bits to fetch initially." table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" "Create the first table from scratch." tableStart _ 2. "See above" tableSize _ 1 bitShift: minBits. tableEnd _ tableStart + tableSize. "Store the terminal symbols" valueIndex _ (counts at: minBits+1). tableIndex _ 0. 1 to: valueIndex do:[:i| table at: tableStart + tableIndex put: (values at: i). tableIndex _ tableIndex + 1]. "Fill up remaining entries with invalid entries" tableStack _ OrderedCollection new: 10. "Should be more than enough" tableStack addLast: (Array with: minBits "Number of bits (e.g., depth) for this table" with: tableStart "Start of table" with: tableIndex "Next index in table" with: minBits "Number of delta bits encoded in table" with: tableSize - valueIndex "Entries remaining in table"). "Go to next value index" valueIndex _ valueIndex + 1. "Walk over remaining bit lengths and create new subtables" minBits+1 to: maxBits do:[:bits| numValues _ counts at: bits+1. [numValues > 0] whileTrue:["Create a new subtable" lastTable _ tableStack last. lastTableStart _ lastTable at: 2. lastTableIndex _ lastTable at: 3. deltaBits _ bits - (lastTable at: 1). "Make up a table of deltaBits size" tableSize _ 1 bitShift: deltaBits. tableStart _ tableEnd. tableEnd _ tableEnd + tableSize. [tableEnd > table size ] whileTrue:[table _ self growHuffmanTable: table]. "Connect to last table" self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused" table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. lastTable at: 3 put: lastTableIndex+1. lastTable at: 5 put: (lastTable at: 5) - 1. self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize" "Store terminal values" maxEntries _ numValues min: tableSize. tableIndex _ 0. 1 to: maxEntries do:[:i| table at: tableStart + tableIndex put: (values at: valueIndex). valueIndex _ valueIndex + 1. numValues _ numValues - 1. tableIndex _ tableIndex+1]. "Check if we have filled up the current table completely" maxEntries = tableSize ifTrue:[ "Table has been filled. Back up to the last table with space left." [tableStack isEmpty not and:[(tableStack last at: 5) = 0]] whileTrue:[tableStack removeLast]. ] ifFalse:[ "Table not yet filled. Put it back on the stack." tableStack addLast: (Array with: bits "Nr. of bits in this table" with: tableStart "Start of table" with: tableIndex "Index in table" with: deltaBits "delta bits of table" with: tableSize - maxEntries "Unused entries in table"). ]. ]. ]. ^table copyFrom: 1 to: tableEnd-1! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:44'! decodeValueFrom: table "Decode the next value in the receiver using the given huffman table." | bits bitsNeeded tableIndex value | bitsNeeded _ (table at: 1) bitShift: -24. "Initial bits needed" tableIndex _ 2. "First real table" [bits _ self getBits: bitsNeeded. "Get bits" value _ table at: (tableIndex + bits). "Lookup entry in table" (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" whileFalse:["Fetch sub table" tableIndex _ value bitAnd: 16rFFFF. "Table offset in low 16 bit" bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. ^value! ! !JPEGReadStream methodsFor: 'huffman trees' stamp: 'ar 3/4/2001 18:21'! growHuffmanTable: table | newTable | newTable _ table species new: table size * 2. newTable replaceFrom: 1 to: table size with: table startingAt: 1. ^newTable! ! !JPEGReadStream commentStamp: '<historical>' prior: 0! Encapsulates huffman encoded access to JPEG data. The following layout is fixed for the JPEG primitives to work: collection <ByteArray | String> position <SmallInteger> readLimit <SmallInteger> bitBuffer <SmallInteger> bitsInBuffer <SmallInteger>! !JPEGReadStream class methodsFor: 'class initialization' stamp: 'ar 3/4/2001 18:32'! initialize "JPEGReadStream initialize" MaxBits _ 16.! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'ar 3/7/2001 00:18'! decompressionTest "Test decompression; don't generate actual image" | xStep yStep x y | MessageTally spyOn:[ ditherMask _ DitherMasks at: 32. residuals _ WordArray new: 3. sosSeen _ false. self parseFirstMarker. [sosSeen] whileFalse: [self parseNextMarker]. xStep _ mcuWidth * DCTSize. yStep _ mcuHeight * DCTSize. y _ 0. 1 to: mcuRowsInScan do: [:row | x _ 0. 1 to: mcusPerRow do: [:col | self decodeMCU. self idctMCU. self colorConvertMCU. x _ x + xStep]. y _ y + yStep]. ].! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'ar 10/28/2001 16:25'! nextImageDitheredToDepth: depth | form xStep yStep x y bb | ditherMask _ DitherMasks at: depth ifAbsent: [self error: 'can only dither to display depths']. residuals _ WordArray new: 3. sosSeen _ false. self parseFirstMarker. [sosSeen] whileFalse: [self parseNextMarker]. form _ Form extent: (width @ height) depth: depth. bb _ BitBlt current toForm: form. bb sourceForm: mcuImageBuffer. bb colorMap: (mcuImageBuffer colormapIfNeededFor: form). bb sourceRect: mcuImageBuffer boundingBox. bb combinationRule: Form over. xStep _ mcuWidth * DCTSize. yStep _ mcuHeight * DCTSize. y _ 0. 1 to: mcuRowsInScan do: [:row | x _ 0. 1 to: mcusPerRow do: [:col | self decodeMCU. self idctMCU. self colorConvertMCU. bb destX: x; destY: y; copyBits. x _ x + xStep]. y _ y + yStep]. ^ form! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'ar 3/4/2001 17:26'! setStream: aStream "Feed it in from an existing source" stream _ JPEGReadStream on: aStream upToEnd.! ! !JPEGReadWriter methodsFor: 'testing' stamp: 'ar 3/4/2001 00:50'! understandsImageFormat "Answer true if the image stream format is understood by this decoder." self next = 16rFF ifFalse: [^ false]. self next = 16rD8 ifFalse: [^ false]. ^ true ! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/4/2001 18:38'! initialSOSSetup mcuWidth _ (components detectMax: [:c | c widthInBlocks]) widthInBlocks. mcuHeight _ (components detectMax: [:c | c heightInBlocks]) heightInBlocks. components do:[:c | c mcuWidth: mcuWidth mcuHeight: mcuHeight dctSize: DCTSize]. stream resetBitBuffer.! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/13/2001 13:06'! okToIgnoreMarker: aMarker ^ (((16rE0 to: 16rEF) includes: aMarker) "unhandled APPn markers" or: [aMarker = 16rDC or: [aMarker = 16rFE]]) "DNL or COM markers" or: [aMarker = 16r99] "Whatever that is"! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/6/2001 22:28'! parseAPPn | length buffer thumbnailLength markerStart | markerStart _ self position. length _ self nextWord. buffer _ self next: 4. (buffer asString = 'JFIF') ifFalse: [ "Skip APPs that we're not interested in" stream next: length-6. ^self]. self next. majorVersion _ self next. minorVersion _ self next. densityUnit _ self next. xDensity _ self nextWord. yDensity _ self nextWord. thumbnailLength _ self next * self next * 3. length _ length - (self position - markerStart). length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail length is incorrect.']. self next: length! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/12/2001 11:28'! parseFirstMarker | marker | self next = 16rFF ifFalse: [self error: 'JFIF marker expected']. marker _ self next. marker = 16rD9 ifTrue: [^self "halt: 'EOI encountered.'"]. marker = 16rD8 ifFalse: [self error: 'SOI marker expected']. self parseStartOfInput. ! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/4/2001 18:36'! parseHuffmanTable | length markerStart index bits count huffVal isACTable hTable | markerStart _ self position. length _ self nextWord. [self position - markerStart >= length] whileFalse: [index _ self next. isACTable _ (index bitAnd: 16r10) ~= 0. index _ (index bitAnd: 16r0F) + 1. index > HuffmanTableSize ifTrue: [self error: 'image has more than ', HuffmanTableSize printString, ' quantization tables']. bits _ self next: 16. count _ bits sum. (count > 256 or: [(count > (length - (self position - markerStart)))]) ifTrue: [self error: 'Huffman Table count is incorrect']. huffVal _ self next: count. hTable _ stream buildLookupTable: huffVal counts: bits. isACTable ifTrue: [self hACTable at: index put: hTable] ifFalse: [self hDCTable at: index put: hTable]].! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'mir 6/12/2001 11:28'! parseNextMarker "Parse the next marker of the stream" | byte discardedBytes | discardedBytes _ 0. [(byte _ self next) = 16rFF] whileFalse: [discardedBytes _ discardedBytes + 1]. [[(byte _ self next) = 16rFF] whileTrue. byte = 16r00] whileTrue: [discardedBytes _ discardedBytes + 2]. discardedBytes > 0 ifTrue: [self "notifyWithLabel: 'warning: extraneous data discarded'"]. self perform: (JFIFMarkerParser at: byte ifAbsent: [(self okToIgnoreMarker: byte) ifTrue: [#skipMarker] ifFalse: [self error: 'marker ', byte hex , ' cannot be handled']])! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/3/2001 22:19'! parseQuantizationTable | length markerStart n prec value table | markerStart _ self position. length _ self nextWord. [self position - markerStart >= length] whileFalse: [value _ self next. n _ (value bitAnd: 16r0F) + 1. prec _ (value >> 4) > 0. n > QuantizationTableSize ifTrue: [self error: 'image has more than ', QuantizationTableSize printString, ' quantization tables']. table _ IntegerArray new: DCTSize2. 1 to: DCTSize2 do: [:i | value _ (prec ifTrue: [self nextWord] ifFalse: [self next]). table at: (JPEGNaturalOrder at: i) put: value]. self useFloatingPoint ifTrue: [self scaleQuantizationTable: table]. self qTable at: n put: table]! ! !JPEGReadWriter methodsFor: 'marker parsing' stamp: 'ar 3/7/2001 01:01'! perScanSetup mcusPerRow _ (width / (mcuWidth * DCTSize)) ceiling. mcuRowsInScan _ (height / (mcuHeight * DCTSize)) ceiling. (currentComponents size = 3 or: [currentComponents size = 1]) ifFalse: [self error: 'JPEG color space not recognized']. mcuMembership _ OrderedCollection new. currentComponents withIndexDo: [:c :i | c priorDCValue: 0. mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: [:b | i])]. mcuMembership _ mcuMembership asArray. mcuSampleBuffer _ (1 to: mcuMembership size) collect: [:i | IntegerArray new: DCTSize2]. currentComponents withIndexDo: [:c :i | c initializeSampleStreamBlocks: ((1 to: mcuMembership size) select: [:j | i = (mcuMembership at: j)] thenCollect: [:j | mcuSampleBuffer at: j])]. mcuImageBuffer _ Form extent: (mcuWidth @ mcuHeight) * DCTSize depth: 32. restartsToGo _ restartInterval.! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 20:55'! decodeBlockInto: anArray component: aColorComponent dcTable: huffmanDC acTable: huffmanAC | byte i zeroCount | byte _ stream decodeValueFrom: huffmanDC. byte ~= 0 ifTrue: [byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte]. byte _ aColorComponent updateDCValue: byte. anArray atAllPut: 0. anArray at: 1 put: byte. i _ 2. [i <= DCTSize2] whileTrue: [byte _ stream decodeValueFrom: huffmanAC. zeroCount _ byte >> 4. byte _ byte bitAnd: 16r0F. byte ~= 0 ifTrue: [i _ i + zeroCount. byte _ self scaleAndSignExtend: ( self getBits: byte) inFieldWidth: byte. anArray at: (JPEGNaturalOrder at: i) put: byte] ifFalse: [zeroCount = 15 ifTrue: [i _ i + zeroCount] ifFalse: [^ self]]. i _ i + 1] ! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/7/2001 01:00'! decodeMCU | comp ci | (restartInterval ~= 0 and: [restartsToGo = 0]) ifTrue: [self processRestart]. 1 to: mcuMembership size do:[:i| ci _ mcuMembership at: i. comp _ currentComponents at: ci. self primDecodeBlockInto: (mcuSampleBuffer at: i) component: comp dcTable: (hDCTable at: comp dcTableIndex) acTable: (hACTable at: comp acTableIndex) stream: stream. ]. restartsToGo _ restartsToGo - 1.! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:27'! getBits: requestedBits ^stream getBits: requestedBits! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 21:32'! primDecodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable stream: jpegStream <primitive: 'primitiveDecodeMCU' module: 'JPEGReaderPlugin'> ^self decodeBlockInto: sampleBuffer component: comp dcTable: dcTable acTable: acTable! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 17:40'! processRestart stream resetBitBuffer. self parseNextMarker. currentComponents do: [:c | c priorDCValue: 0]. restartsToGo _ restartInterval.! ! !JPEGReadWriter methodsFor: 'huffman encoding' stamp: 'ar 3/4/2001 01:17'! scaleAndSignExtend: aNumber inFieldWidth: w aNumber < (1 bitShift: (w - 1)) ifTrue: [^aNumber - (1 bitShift: w) + 1] ifFalse: [^aNumber]! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! idctBlockInt: anArray component: aColorComponent ^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:34'! idctBlockInt: anArray qt: qt | ws anACTerm dcval z1 z2 z3 z4 z5 t0 t1 t2 t3 t10 t11 t12 t13 shift | ws _ Array new: DCTSize2. "Pass 1: process columns from anArray, store into work array" shift _ 1 bitShift: ConstBits - Pass1Bits. 1 to: DCTSize do: [:i | anACTerm _ nil. 1 to: DCTSize-1 do:[:row| anACTerm ifNil:[ (anArray at: row * DCTSize + i) = 0 ifFalse:[anACTerm _ row]]]. anACTerm == nil ifTrue: [dcval _ (anArray at: i) * (qt at: 1) bitShift: Pass1Bits. 0 to: DCTSize-1 do: [:j | ws at: (j * DCTSize + i) put: dcval]] ifFalse: [z2 _ (anArray at: (DCTSize * 2 + i)) * (qt at: (DCTSize * 2 + i)). z3 _ (anArray at: (DCTSize * 6 + i)) * (qt at: (DCTSize * 6 + i)). z1 _ (z2 + z3) * FIXn0n541196100. t2 _ z1 + (z3 * FIXn1n847759065 negated). t3 _ z1 + (z2 * FIXn0n765366865). z2 _ (anArray at: i) * (qt at: i). z3 _ (anArray at: (DCTSize * 4 + i)) * (qt at: (DCTSize * 4 + i)). t0 _ (z2 + z3) bitShift: ConstBits. t1 _ (z2 - z3) bitShift: ConstBits. t10 _ t0 + t3. t13 _ t0 - t3. t11 _ t1 + t2. t12 _ t1 - t2. t0 _ (anArray at: (DCTSize * 7 + i)) * (qt at: (DCTSize * 7 + i)). t1 _ (anArray at: (DCTSize * 5 + i)) * (qt at: (DCTSize * 5 + i)). t2 _ (anArray at: (DCTSize * 3 + i)) * (qt at: (DCTSize * 3 + i)). t3 _ (anArray at: (DCTSize + i)) * (qt at: (DCTSize + i)). z1 _ t0 + t3. z2 _ t1 + t2. z3 _ t0 + t2. z4 _ t1 + t3. z5 _ (z3 + z4) * FIXn1n175875602. t0 _ t0 * FIXn0n298631336. t1 _ t1 * FIXn2n053119869. t2 _ t2 * FIXn3n072711026. t3 _ t3 * FIXn1n501321110. z1 _ z1 * FIXn0n899976223 negated. z2 _ z2 * FIXn2n562915447 negated. z3 _ z3 * FIXn1n961570560 negated. z4 _ z4 * FIXn0n390180644 negated. z3 _ z3 + z5. z4 _ z4 + z5. t0 _ t0 + z1 + z3. t1 _ t1 +z2 +z4. t2 _ t2 + z2 + z3. t3 _ t3 + z1 + z4. ws at: i put: (t10 + t3) >> (ConstBits - Pass1Bits). ws at: (DCTSize * 7 + i) put: (t10 - t3) // shift. ws at: (DCTSize * 1 + i) put: (t11 + t2) // shift. ws at: (DCTSize * 6 + i) put: (t11 - t2) // shift. ws at: (DCTSize * 2 + i) put: (t12 + t1) // shift. ws at: (DCTSize * 5 + i) put: (t12 - t1) // shift. ws at: (DCTSize * 3 + i) put: (t13 + t0) // shift. ws at: (DCTSize * 4 + i) put: (t13 - t0) // shift]]. "Pass 2: process rows from work array, store back into anArray" shift _ 1 bitShift: ConstBits + Pass1Bits + 3. 0 to: DCTSize2-DCTSize by: DCTSize do: [:i | z2 _ ws at: i + 3. z3 _ ws at: i + 7. z1 _ (z2 + z3) * FIXn0n541196100. t2 _ z1 + (z3 * FIXn1n847759065 negated). t3 _ z1 + (z2 * FIXn0n765366865). t0 _ (ws at: (i + 1)) + (ws at: (i + 5)) bitShift: ConstBits. t1 _ (ws at: (i + 1)) - (ws at: (i + 5)) bitShift: ConstBits. t10 _ t0 + t3. t13 _ t0 - t3. t11 _ t1 + t2. t12 _ t1 -t2. t0 _ ws at: (i + 8). t1 _ ws at: (i + 6). t2 _ ws at: (i + 4). t3 _ ws at: (i + 2). z1 _ t0 + t3. z2 _ t1 + t2. z3 _ t0 + t2. z4 _ t1 + t3. z5 _ (z3 + z4) * FIXn1n175875602. t0 _ t0 * FIXn0n298631336. t1 _ t1 * FIXn2n053119869. t2 _ t2 * FIXn3n072711026. t3 _ t3 * FIXn1n501321110. z1 _ z1 * FIXn0n899976223 negated. z2 _ z2 * FIXn2n562915447 negated. z3 _ z3 * FIXn1n961570560 negated. z4 _ z4 * FIXn0n390180644 negated. z3 _ z3 + z5. z4 _ z4 + z5. t0 _ t0 + z1 + z3. t1 _ t1 + z2 + z4. t2 _ t2 + z2 + z3. t3 _ t3 + z1 + z4. anArray at: (i + 1) put: (self sampleRangeLimit: (t10 + t3) // shift + SampleOffset). anArray at: (i + 8) put: (self sampleRangeLimit: (t10 - t3) // shift + SampleOffset). anArray at: (i + 2) put: (self sampleRangeLimit: (t11 + t2) // shift + SampleOffset). anArray at: (i + 7) put: (self sampleRangeLimit: (t11 - t2) // shift + SampleOffset). anArray at: (i + 3) put: (self sampleRangeLimit: (t12 + t1) // shift + SampleOffset). anArray at: (i + 6) put: (self sampleRangeLimit: (t12 - t1) // shift + SampleOffset). anArray at: (i + 4) put: (self sampleRangeLimit: (t13 + t0) // shift + SampleOffset). anArray at: (i + 5) put: (self sampleRangeLimit: (t13 - t0) // shift + SampleOffset)]. ! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/7/2001 00:58'! idctMCU | comp fp ci | fp _ self useFloatingPoint. 1 to: mcuMembership size do:[:i| ci _ mcuMembership at: i. comp _ currentComponents at: ci. fp ifTrue:[ self idctBlockFloat: (mcuSampleBuffer at: i) component: comp. ] ifFalse:[ self primIdctInt: (mcuSampleBuffer at: i) qt: (qTable at: comp qTableIndex)]].! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:37'! primIdctBlockInt: anArray component: aColorComponent ^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! primIdctInt: anArray qt: qt <primitive: 'primitiveIdctInt' module: 'JPEGReaderPlugin'> ^self idctBlockInt: anArray qt: qt! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:18'! colorConvertFloatYCbCrMCU | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | ySampleStream _ currentComponents at: 1. cbSampleStream _ currentComponents at: 2. crSampleStream _ currentComponents at: 3. ySampleStream resetSampleStream. cbSampleStream resetSampleStream. crSampleStream resetSampleStream. bits _ mcuImageBuffer bits. 1 to: bits size do: [:i | y _ ySampleStream nextSample. cb _ cbSampleStream nextSample - FloatSampleOffset. cr _ crSampleStream nextSample - FloatSampleOffset. red _ self sampleFloatRangeLimit: (y + (1.40200 * cr)). green _ self sampleFloatRangeLimit: (y - (0.34414 * cb) - (0.71414 * cr)). blue _ self sampleFloatRangeLimit: (y + (1.77200 * cb)). bits at: i put: 16rFF000000 + (red << 16) + (green << 8) + blue]. ! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:17'! colorConvertGrayscaleMCU | ySampleStream y bits | ySampleStream _ currentComponents at: 1. ySampleStream resetSampleStream. bits _ mcuImageBuffer bits. 1 to: bits size do: [:i | y _ (ySampleStream nextSample) + (residuals at: 2). y > MaxSample ifTrue: [y _ MaxSample]. residuals at: 2 put: (y bitAnd: ditherMask). y _ y bitAnd: MaxSample - ditherMask. y < 1 ifTrue: [y _ 1]. bits at: i put: 16rFF000000 + (y<<16) + (y<<8) + y]. ! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:18'! colorConvertIntYCbCrMCU | ySampleStream crSampleStream cbSampleStream y cb cr red green blue bits | ySampleStream _ currentComponents at: 1. cbSampleStream _ currentComponents at: 2. crSampleStream _ currentComponents at: 3. ySampleStream resetSampleStream. cbSampleStream resetSampleStream. crSampleStream resetSampleStream. bits _ mcuImageBuffer bits. 1 to: bits size do: [:i | y _ ySampleStream nextSample. cb _ cbSampleStream nextSample - SampleOffset. cr _ crSampleStream nextSample - SampleOffset. red _ y + ((FIXn1n40200 * cr) // 65536) + (residuals at: 1). red > MaxSample ifTrue: [red _ MaxSample] ifFalse: [red < 0 ifTrue: [red _ 0]]. residuals at: 1 put: (red bitAnd: ditherMask). red _ red bitAnd: MaxSample - ditherMask. red < 1 ifTrue: [red _ 1]. green _ y - ((FIXn0n34414 * cb) // 65536) - ((FIXn0n71414 * cr) // 65536) + (residuals at: 2). green > MaxSample ifTrue: [green _ MaxSample] ifFalse: [green < 0 ifTrue: [green _ 0]]. residuals at: 2 put: (green bitAnd: ditherMask). green _ green bitAnd: MaxSample - ditherMask. green < 1 ifTrue: [green _ 1]. blue _ y + ((FIXn1n77200 * cb) // 65536) + (residuals at: 3). blue > MaxSample ifTrue: [blue _ MaxSample] ifFalse: [blue < 0 ifTrue: [blue _ 0]]. residuals at: 3 put: (blue bitAnd: ditherMask). blue _ blue bitAnd: MaxSample - ditherMask. blue < 1 ifTrue: [blue _ 1]. bits at: i put: 16rFF000000 + (red bitShift: 16) + (green bitShift: 8) + blue]. ! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/7/2001 01:02'! colorConvertMCU ^ currentComponents size = 3 ifTrue: [self useFloatingPoint ifTrue: [self colorConvertFloatYCbCrMCU] ifFalse: [self primColorConvertYCbCrMCU: currentComponents bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.]] ifFalse: [self primColorConvertGrayscaleMCU]! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 22:19'! primColorConvertGrayscaleMCU self primColorConvertGrayscaleMCU: (currentComponents at: 1) bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/15/2001 18:11'! primColorConvertGrayscaleMCU: componentArray bits: bits residuals: residualArray ditherMask: mask <primitive: 'primitiveColorConvertGrayscaleMCU' module: 'JPEGReaderPlugin'> "JPEGReaderPlugin doPrimitive: #primitiveColorConvertGrayscaleMCU." ^self colorConvertGrayscaleMCU! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertIntYCbCrMCU self primColorConvertYCbCrMCU: currentComponents bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask <primitive: 'primitiveColorConvertMCU' module: 'JPEGReaderPlugin'> ^self colorConvertIntYCbCrMCU! ! !JPEGReadWriter methodsFor: 'private' stamp: 'ar 3/4/2001 17:34'! on: aStream super on: aStream. stream _ JPEGReadStream on: stream upToEnd.! ! !JPEGReadWriter class methodsFor: 'initialization' stamp: 'ar 3/3/2001 23:07'! initialize "JPEGReadWriter initialize" "general constants" DCTSize _ 8. MaxSample _ (2 raisedToInteger: DCTSize) - 1. SampleOffset _ MaxSample // 2. FloatSampleOffset _ SampleOffset asFloat. DCTSize2 _ DCTSize squared. QuantizationTableSize _ 4. HuffmanTableSize _ 4. "floating-point Inverse Discrete Cosine Transform (IDCT) constants" ConstBits _ 13. Pass1Bits _ 2. DCTK1 _ 2 sqrt. DCTK2 _ 1.847759065. DCTK3 _ 1.082392200. DCTK4 _ -2.613125930. Pass1Div _ 1 bitShift: ConstBits - Pass1Bits. Pass2Div _ 1 bitShift: ConstBits + Pass1Bits + 3. "fixed-point Inverse Discrete Cosine Transform (IDCT) constants" FIXn0n298631336 _ 2446. FIXn0n390180644 _ 3196. FIXn0n541196100 _ 4433. FIXn0n765366865 _ 6270. FIXn0n899976223 _ 7373. FIXn1n175875602 _ 9633. FIXn1n501321110 _ 12299. FIXn1n847759065 _ 15137. FIXn1n961570560 _ 16069. FIXn2n053119869 _ 16819. FIXn2n562915447 _ 20995. FIXn3n072711026 _ 25172. "fixed-point color conversion constants" FIXn0n34414 _ 22554. FIXn0n71414 _ 46802. FIXn1n40200 _ 91881. FIXn1n77200 _ 116130. "reordering table from JPEG zig-zag order" JPEGNaturalOrder _ #( 1 2 9 17 10 3 4 11 18 25 33 26 19 12 5 6 13 20 27 34 41 49 42 35 28 21 14 7 8 15 22 29 36 43 50 57 58 51 44 37 30 23 16 24 31 38 45 52 59 60 53 46 39 32 40 47 54 61 62 55 48 56 63 64). "scale factors for the values in the Quantization Tables" QTableScaleFactor _ (0 to: DCTSize-1) collect: [:k | k = 0 ifTrue: [1.0] ifFalse: [(k * Float pi / 16) cos * 2 sqrt]]. "dithering masks" (DitherMasks _ Dictionary new) add: 0 -> 0; add: 1 -> 127; add: 2 -> 63; add: 4 -> 63; add: 8 -> 31; add: 16 -> 7; add: 32 -> 0. "dictionary of marker parsers" (JFIFMarkerParser _ Dictionary new) add: (16r01 -> #parseNOP); add: (16rC0 -> #parseStartOfFile); add: (16rC4 -> #parseHuffmanTable); addAll: ((16rD0 to: 16rD7) collect: [:m | Association key: m value: #parseNOP]); add: (16rD8 -> #parseStartOfInput); add: (16rD9 -> #parseEndOfInput); add: (16rDA -> #parseStartOfScan); add: (16rDB -> #parseQuantizationTable); add: (16rDD -> #parseDecoderRestartInterval); add: (16rE0 -> #parseAPPn); add: (16rE1 -> #parseAPPn)! ! !JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('jpg' 'jpeg')! ! !JPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! understandsImageFormat: aStream (JPEGReadWriter2 understandsImageFormat: aStream) ifTrue:[^false]. aStream reset. aStream next = 16rFF ifFalse: [^ false]. aStream next = 16rD8 ifFalse: [^ false]. ^true! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'JMM 1/11/2005 14:56'! compress: aForm quality: quality "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high), where -1 means default." | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. "odd width images of depth 16 give problems; avoid them." sourceForm _ (aForm depth = 32) | (aForm width even & (aForm depth = 16)) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32]. jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. buffer _ ByteArray new: sourceForm width * sourceForm height + 1024. byteCount _ self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: false errorMgr: jpegErrorMgr2Struct. byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data']. ^ buffer copyFrom: 1 to: byteCount ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:01'! imageExtent: aByteArray "Answer the extent of the compressed image encoded in the given ByteArray." | jpegDecompressStruct jpegErrorMgr2Struct w h | jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w _ self primImageWidth: jpegDecompressStruct. h _ self primImageHeight: jpegDecompressStruct. ^ w @ h ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:23'! nextImage "Decode and answer a Form from my stream." ^ self nextImageSuggestedDepth: Display depth ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'sd 1/30/2004 15:19'! nextImageSuggestedDepth: depth "Decode and answer a Form of the given depth from my stream. Close the stream if it is a file stream. Possible depths are 16-bit and 32-bit." | bytes width height form jpegDecompressStruct jpegErrorMgr2Struct depthToUse | bytes _ stream upToEnd. stream close. jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: bytes errorMgr: jpegErrorMgr2Struct. width _ self primImageWidth: jpegDecompressStruct. height _ self primImageHeight: jpegDecompressStruct. "Odd width images of depth 16 gave problems. Avoid them (or check carefully!!)" depthToUse _ ((depth = 32) | width odd) ifTrue: [32] ifFalse: [16]. form _ Form extent: width@height depth: depthToUse. (width = 0 or: [height = 0]) ifTrue: [^ form]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: bytes onForm: form doDithering: true errorMgr: jpegErrorMgr2Struct. ^ form ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'jm 11/20/2001 10:21'! nextPutImage: aForm "Encode the given Form on my stream with default quality." ^ self nextPutImage: aForm quality: -1 progressiveJPEG: false ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'JMM 1/11/2005 14:45'! nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag "Encode the given Form on my stream with the given settings. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. "odd width images of depth 16 give problems; avoid them." sourceForm _ (aForm depth = 32) | (aForm width even & (aForm depth = 16)) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32]. jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. buffer _ ByteArray new: sourceForm width * sourceForm height + 1024. byteCount _ self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: progressiveFlag errorMgr: jpegErrorMgr2Struct. byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data']. stream next: byteCount putAll: buffer startingAt: 1. self close. ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 12/7/2001 13:49'! uncompress: aByteArray into: aForm "Uncompress an image from the given ByteArray into the given Form. Fails if the given Form has the wrong dimensions or depth. If aForm has depth 16, do ordered dithering." | jpegDecompressStruct jpegErrorMgr2Struct w h | aForm unhibernate. jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w _ self primImageWidth: jpegDecompressStruct. h _ self primImageHeight: jpegDecompressStruct. ((aForm width = w) & (aForm height = h)) ifFalse: [ ^ self error: 'form dimensions do not match']. "odd width images of depth 16 give problems; avoid them" w odd ifTrue: [ aForm depth = 32 ifFalse: [^ self error: 'must use depth 32 with odd width']] ifFalse: [ ((aForm depth = 16) | (aForm depth = 32)) ifFalse: [^ self error: 'must use depth 16 or 32']]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: true errorMgr: jpegErrorMgr2Struct. ! ! !JPEGReadWriter2 methodsFor: 'public access' stamp: 'jmv 12/7/2001 13:48'! uncompress: aByteArray into: aForm doDithering: ditherFlag "Uncompress an image from the given ByteArray into the given Form. Fails if the given Form has the wrong dimensions or depth. If aForm has depth 16 and ditherFlag = true, do ordered dithering." | jpegDecompressStruct jpegErrorMgr2Struct w h | aForm unhibernate. jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w _ self primImageWidth: jpegDecompressStruct. h _ self primImageHeight: jpegDecompressStruct. ((aForm width = w) & (aForm height = h)) ifFalse: [ ^ self error: 'form dimensions do not match']. "odd width images of depth 16 give problems; avoid them" w odd ifTrue: [ aForm depth = 32 ifFalse: [^ self error: 'must use depth 32 with odd width']] ifFalse: [ ((aForm depth = 16) | (aForm depth = 32)) ifFalse: [^ self error: 'must use depth 16 or 32']]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: ditherFlag errorMgr: jpegErrorMgr2Struct. ! ! !JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:40'! isPluginPresent ^self primJPEGPluginIsPresent! ! !JPEGReadWriter2 methodsFor: 'testing' stamp: 'ar 11/27/2001 00:39'! understandsImageFormat "Answer true if the image stream format is understood by this decoder." self isPluginPresent ifFalse:[^false]. "cannot read it otherwise" self next = 16rFF ifFalse: [^ false]. self next = 16rD8 ifFalse: [^ false]. ^ true ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:34'! primImageHeight: aJPEGCompressStruct <primitive: 'primImageHeight' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primImageWidth: aJPEGCompressStruct <primitive: 'primImageWidth' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGCompressStructSize <primitive: 'primJPEGCompressStructSize' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGDecompressStructSize <primitive: 'primJPEGDecompressStructSize' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGErrorMgr2StructSize <primitive: 'primJPEGErrorMgr2StructSize' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'ar 11/27/2001 00:39'! primJPEGPluginIsPresent <primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'> ^false! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct <primitive: 'primJPEGReadHeaderfromByteArrayerrorMgr' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jmv 12/7/2001 13:45'! primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct <primitive: 'primJPEGReadImagefromByteArrayonFormdoDitheringerrorMgr' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct <primitive: 'primJPEGWriteImageonByteArrayformqualityprogressiveJPEGerrorMgr' module: 'JPEGReadWriter2Plugin'> self primitiveFailed ! ! !JPEGReadWriter2 commentStamp: '<historical>' prior: 0! I provide fast JPEG compression and decompression. I require the VM pluginJPEGReadWriter2Plugin, which is typically stored in same directory as the Squeak virtual machine. JPEGReadWriter2Plugin is based on LIBJPEG library. This sentence applies to the plugin: "This software is based in part on the work of the Independent JPEG Group". The LIBJPEG license allows it to be used free for any purpose so long as its origin and copyright are acknowledged. You can read more about LIBJPEG and get the complete source code at www.ijg.org. ! !JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! primJPEGPluginIsPresent <primitive: 'primJPEGPluginIsPresent' module: 'JPEGReadWriter2Plugin'> ^false! ! !JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'jm 12/22/2001 11:55'! putForm: aForm quality: quality progressiveJPEG: progressiveFlag onFileNamed: fileName "Store the given Form as a JPEG file of the given name, overwriting any existing file of that name. Quality goes from 0 (low) to 100 (high), where -1 means default. If progressiveFlag is true, encode as a progressive JPEG." | writer | FileDirectory deleteFilePath: fileName. writer _ self on: (FileStream newFileNamed: fileName) binary. Cursor write showWhile: [ writer nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag]. writer close. ! ! !JPEGReadWriter2 class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:56'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('jpg' 'jpeg')! ! !JapaneseEnvironment methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 15:46'! beCurrentNaturalLanguage super beCurrentNaturalLanguage. Preferences restoreDefaultFontsForJapanese. ! ! !JapaneseEnvironment commentStamp: '<historical>' prior: 0! This class provides the Japanese support. Since it has been used most other than default 'latin-1' languages, this tends to be a good place to look at when you want to know what a typical subclass of LanguageEnvironment should do. ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 8/14/2003 15:40'! beCurrentNaturalLanguage super beCurrentNaturalLanguage. Preferences restoreDefaultFontsForJapanese. ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 8/3/2004 21:25'! flapTabTextFor: aString in: aFlapTab | string | string _ super flapTabTextFor: aString. string isEmptyOrNil ifTrue: [^ self]. string _ aFlapTab orientation == #vertical ifTrue: [string copyReplaceAll: 'ー' with: '｜'] ifFalse: [string copyReplaceAll: '｜' with: 'ー']. ^ string. !]lang[(211 1 9 1 41 1 9 1 16)0,5,0,5,0,5,0,5,0! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 22:00'! fromJISX0208String: aString ^ aString collect: [:each | MultiCharacter leadingChar: JapaneseEnvironment leadingChar code: (each asUnicode)]. ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 11/12/2002 11:09'! removeFonts ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 21:54'! scanSelector ^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern: ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:49'! traditionalCharsetClass ^ JISX0208. ! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:40'! clipboardInterpreterClass | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^NoConversionClipboardInterpreter]. platformName = 'Win32' ifTrue: [^WinShiftJISClipboardInterpreter]. platformName = 'Mac OS' ifTrue: [^MacShiftJISClipboardInterpreter]. ^platformName = 'unix' ifTrue: [(ShiftJISTextConverter encodingNames includes: X11Encoding getEncoding) ifTrue: [MacShiftJISClipboardInterpreter] ifFalse: [UnixJPClipboardInterpreter]] ifFalse: [ NoConversionClipboardInterpreter ]! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/15/2004 18:18'! fileNameConverterClass ^ self systemConverterClass. ! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 22:37'! inputInterpreterClass | platformName osVersion encoding | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^MacRomanInputInterpreter]. platformName = 'Win32' ifTrue: [^WinShiftJISInputInterpreter]. platformName = 'Mac OS' ifTrue: [^('10*' match: SmalltalkImage current osVersion) ifTrue: [MacUnicodeInputInterpreter] ifFalse: [MacShiftJISInputInterpreter]]. platformName = 'unix' ifTrue: [encoding := X11Encoding encoding. (EUCJPTextConverter encodingNames includes: encoding) ifTrue: [^UnixEUCJPInputInterpreter]. (UTF8TextConverter encodingNames includes: encoding) ifTrue: [^UnixUTF8JPInputInterpreter]. (ShiftJISTextConverter encodingNames includes: encoding) ifTrue: [^MacShiftJISInputInterpreter]]. ^MacRomanInputInterpreter! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 21:55'! leadingChar ^ 5. ! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/21/2004 19:09'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('ja' 'ja-etoys' )! ! !JapaneseEnvironment class methodsFor: 'subclass responsibilities' stamp: 'T2 2/3/2005 13:07'! systemConverterClass | platformName osVersion encoding | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^UTF8TextConverter]. (#('Win32' 'ZaurusOS') includes: platformName) ifTrue: [^ShiftJISTextConverter]. platformName = 'Mac OS' ifTrue: [^('10*' match: SmalltalkImage current osVersion) ifTrue: [UTF8TextConverter] ifFalse: [ShiftJISTextConverter]]. platformName = 'unix' ifTrue: [encoding := X11Encoding encoding. encoding ifNil: [^EUCJPTextConverter]. (encoding = 'utf-8') ifTrue: [^UTF8TextConverter]. (encoding = 'shiftjis' | encoding = 'sjis') ifTrue: [^ShiftJISTextConverter]. ^EUCJPTextConverter]. ^MacRomanTextConverter! ! !JapaneseEnvironment class methodsFor: 'public query' stamp: 'nk 7/30/2004 21:43'! defaultEncodingName | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8']. (#('Win32' 'ZaurusOS') includes: platformName) ifTrue: [^'shift-jis']. platformName = 'Mac OS' ifTrue: [^('10*' match: SmalltalkImage current osVersion) ifTrue: ['utf-8'] ifFalse: ['shift-jis']]. ^'unix' = platformName ifTrue: ['euc-jp'] ifFalse: ['mac-roman']! ! !JapaneseEnvironment class methodsFor: 'rendering support' stamp: 'yo 8/3/2004 16:58'! isBreakableAt: index in: text | prev | index = 1 ifTrue: [^ false]. prev _ text at: index - 1. prev leadingChar ~= 1 ifTrue: [^ true]. ^ (('ã€ã€‚，．・：；？ï¼ã‚›ã‚œÂ´ï½€Â¨ï¼¾â€•â€ï¼\〜‖｜…‥’â€ï¼‰ã€•ï¼½ï½ã€‰ã€‹ã€ã€ã€‘°′″℃' includes: (text at: index)) or: ['‘“（〔［｛〈《「『ã€Â°â€²â€³â„ƒï¼ Â§' includes: prev]) not. !]lang[(146 11 1 1 1 4 1 16 1 3 36 11 1 4 25)0,5,0,5,0,5,0,5,0,5,0,5,0,5,0! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 20:00'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add custom items to the menu" super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'set X range' translated action: #setXRange. aCustomMenu add: 'set Y range' translated action: #setYRange. aCustomMenu addLine. aCustomMenu addUpdating: #autoCenterString target: self action: #toggleAutoCenter. aCustomMenu balloonTextForLastItem: 'When auto-center is on, every time you let go of the Joystick knob, it springs back to the neutral position at the center of the device' translated. aCustomMenu addUpdating: #realJoystickString target: self action: #toggleRealJoystick. aCustomMenu balloonTextForLastItem: 'Governs whether this joystick should track the motions of a real, physical joystick attached to the computer.' translated. aCustomMenu addUpdating: #joystickNumberString enablementSelector: #realJoystickInUse target: self selector: #chooseJoystickNumber argumentList: #(). aCustomMenu balloonTextForLastItem: 'Choose which physical device is associated with the joystick.' translated! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 18:30'! autoCenterString "Answer a string characterizing whether or not I have auto-center on" ^ (autoCenter == true ifTrue: ['<yes>'] ifFalse: ['<no>']), ('auto-center' translated)! ! !JoystickMorph methodsFor: 'menu' stamp: 'yo 2/24/2005 17:44'! chooseJoystickNumber "Allow the user to select a joystick number" | result aNumber str | str := self lastRealJoystickIndex asString. result := FillInTheBlank request: ('Joystick device number (currently {1})' translated format: {str}) initialAnswer: str. [aNumber := result asNumber] on: Error do: [:err | ^Beeper beep]. (aNumber > 0 and: [aNumber <= 32]) ifFalse: ["???" ^Beeper beep]. realJoystickIndex := aNumber. self setProperty: #lastRealJoystickIndex toValue: aNumber. self startStepping! ! !JoystickMorph methodsFor: 'menu' stamp: 'yo 2/11/2005 09:19'! joystickNumberString "Answer a string characterizing the joystick number" ^ 'set real joystick number (now {1})' translated format: {self lastRealJoystickIndex asString}. ! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 20:08'! lastRealJoystickIndex "Answer the last remembered real joystick index. Initialize it to 1 if need be" ^ self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1] ! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 19:57'! realJoystickInUse "Answer whether a real joystick is in use" ^ realJoystickIndex notNil! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 4/29/2004 18:29'! realJoystickString "Answer a string characterizing whether or not I am currenty tracking a real joystick" ^ (realJoystickIndex ifNil: ['<no>'] ifNotNil: ['<yes>']), ('track real joystick' translated)! ! !JoystickMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:11'! setXRange | range | range _ FillInTheBlank request: 'Type the maximum value for the X axis' translated initialAnswer: ((xScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString. range isEmpty ifFalse: [ xScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)]. ! ! !JoystickMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 13:11'! setYRange | range | range _ FillInTheBlank request: 'Type the maximum value for the Y axis' translated initialAnswer: ((yScale * (self width - handleMorph width) / 2.0) roundTo: 0.01) printString. range isEmpty ifFalse: [ yScale _ (2.0 * range asNumber asFloat) / (self width - handleMorph width)]. ! ! !JoystickMorph methodsFor: 'menu' stamp: 'sw 8/11/2004 18:15'! toggleRealJoystick "Toggle whether or not one is using a real joystick" realJoystickIndex ifNil: [realJoystickIndex _ self valueOfProperty: #lastRealJoystickIndex ifAbsentPut: [1]. self startStepping] ifNotNil: [self stopTrackingJoystick]! ! !JoystickMorph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 17:26'! initializeToStandAlone "Circumvent SketchMorph's implementation here" self initialize! ! !JoystickMorph methodsFor: 'stepping and presenter' stamp: 'laza 6/8/2003 11:53'! stepTime "Provide for as-fast-as-possible stepping in the case of a real joystick" ^ realJoystickIndex ifNotNil: [0] "fast as we can to track actual joystick" ifNil: [super stepTime]! ! !JoystickMorph methodsFor: 'halos and balloon help' stamp: 'sw 8/11/2004 18:10'! isLikelyRecipientForMouseOverHalos "The automatic mouseover halos interere with the proper functioning of the joystick's knob" ^ false! ! !JoystickMorph commentStamp: 'kfr 10/27/2003 16:25' prior: 0! A widget that simulates a joystick. Mosly used in etoy scripting.! !JoystickMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:40'! descriptionForPartsBin ^ self partName: 'Joystick' categories: #('Useful') documentation: 'A joystick-like control'! ! !JoystickMorph class methodsFor: 'scripting' stamp: 'sw 9/26/2001 04:20'! additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((joystick ( (slot amount 'The amount of displacement' Number readOnly Player getAmount unused unused) (slot angle 'The angular displacement' Number readOnly Player getAngle unused unused) (slot leftRight 'The horizontal displacement' Number readOnly Player getLeftRight unused unused) (slot upDown 'The vertical displacement' Number readOnly Player getUpDown unused unused)))) ! ! !JoystickMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:10'! initialize self registerInFlapsRegistry.! ! !JoystickMorph class methodsFor: 'class initialization' stamp: 'asm 4/14/2003 20:32'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'Scripting'. cl registerQuad: #(JoystickMorph authoringPrototype 'Joystick' 'A joystick-like control') forFlapNamed: 'Supplies']! ! !JoystickMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:36'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !KSX1001 commentStamp: 'yo 10/19/2004 19:53' prior: 0! This class represents the domestic character encoding called KS X 1001 used for Korean.! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:47'! compoundTextSequence ^ CompoundTextSequence. ! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'! initialize " KSX1001 initialize " CompoundTextSequence _ String streamContents: [:stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $C]! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'! leadingChar ^ 3. ! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 11/24/2002 17:03'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state | c1 c2 | state charSize: 2. (state g0Leading ~= self leadingChar) ifTrue: [ state g0Leading: self leadingChar. state g0Size: 2. aStream basicNextPutAll: CompoundTextSequence. ]. c1 _ ascii // 94 + 16r21. c2 _ ascii \\ 94 + 16r21. ^ aStream basicNextPut: (Character value: c1); basicNextPut: (Character value: c2). ! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable ksx1001Table. ! ! !KSX1001 class methodsFor: 'character classification' stamp: 'yo 8/6/2003 05:30'! isLetter: char | value leading | leading _ char leadingChar. value _ char charCode. leading = 0 ifTrue: [^ super isLetter: char]. value _ value // 94 + 1. ^ 1 <= value and: [value < 84]. ! ! !KeyboardEvent methodsFor: 'keyboard' stamp: 'nk 10/13/2004 10:43'! keyString "Answer the string value for this keystroke. This is defined only for keystroke events." ^ String streamContents: [ :s | self printKeyStringOn: s ]! ! !KeyboardEvent methodsFor: 'printing' stamp: 'tk 10/13/2004 15:19'! printKeyStringOn: aStream "Print a readable string representing the receiver on a given stream" | kc inBrackets firstBracket keyString | kc := self keyCharacter. inBrackets := false. firstBracket := [ inBrackets ifFalse: [ aStream nextPut: $<. inBrackets := true ]]. self controlKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Ctrl-' ]. self commandKeyPressed ifTrue: [ firstBracket value. aStream nextPutAll: 'Cmd-' ]. (buttons anyMask: 32) ifTrue: [ firstBracket value. aStream nextPutAll: 'Opt-' ]. (self shiftPressed and: [ keyValue between: 1 and: 31 ]) ifTrue: [ firstBracket value. aStream nextPutAll: 'Shift-' ]. (self controlKeyPressed and: [ keyValue <= 26 ]) ifTrue: [aStream nextPut: (keyValue + $a asciiValue - 1) asCharacter] ifFalse: [keyString := (kc caseOf: { [ Character space ] -> [ ' ' ]. [ Character tab ] -> [ 'tab' ]. [ Character cr ] -> [ 'cr' ]. [ Character lf ] -> [ 'lf' ]. [ Character enter ] -> [ 'enter' ]. [ Character backspace ] -> [ 'backspace' ]. [ Character delete ] -> [ 'delete' ]. [ Character escape ] -> [ 'escape' ]. [ Character arrowDown ] -> [ 'down' ]. [ Character arrowUp ] -> [ 'up' ]. [ Character arrowLeft ] -> [ 'left' ]. [ Character arrowRight ] -> [ 'right' ]. [ Character end ] -> [ 'end' ]. [ Character home ] -> [ 'home' ]. [ Character pageDown ] -> [ 'pageDown' ]. [ Character pageUp ] -> [ 'pageUp' ]. [ Character euro ] -> [ 'euro' ]. [ Character insert ] -> [ 'insert' ]. } otherwise: [ String with: kc ]). keyString size > 1 ifTrue: [ firstBracket value ]. aStream nextPutAll: keyString]. inBrackets ifTrue: [aStream nextPut: $> ]! ! !KeyboardEvent methodsFor: 'printing' stamp: 'nk 10/13/2004 10:42'! printOn: aStream "Print the receiver on a stream" aStream nextPut: $[. aStream nextPutAll: type; nextPutAll: ' '''. self printKeyStringOn: aStream. aStream nextPut: $'. aStream nextPut: $]! ! !KeyboardEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 18:53'! decodeFromStringArray: array "decode the receiver from an array of strings" type := array first asSymbol. position := CanvasDecoder decodePoint: (array second). buttons := CanvasDecoder decodeInteger: (array third). keyValue := CanvasDecoder decodeInteger: array fourth! ! !KeyboardInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 17:26'! initialize ! ! !KeyboardInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 13:53'! nextCharFrom: sensor firstEvt: evtBuf self subclassResponsibility. ! ! !KeyboardInputInterpreter class methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 16:24'! new ^ (self basicNew) initialize; yourself. ! ! !KeyboardMorphForInput methodsFor: 'initialization' stamp: 'yo 2/11/2005 10:39'! addRecordingControls | button switch playRow durRow articRow modRow | "Add chord, rest and delete buttons" playRow _ AlignmentMorph newRow. playRow color: color; borderWidth: 0; layoutInset: 0. playRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. playRow addMorphBack: (switch label: 'chord' translated; actionSelector: #buildChord:). button _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2; color: color. playRow addMorphBack: (button label: ' rest ' translated; actionSelector: #emitRest). button _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2; color: color. playRow addMorphBack: (button label: 'del' translated; actionSelector: #deleteNotes). self addMorph: playRow. playRow align: playRow fullBounds topCenter with: self fullBounds bottomCenter. "Add note duration buttons" durRow _ AlignmentMorph newRow. durRow color: color; borderWidth: 0; layoutInset: 0. durRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. durRow addMorphBack: (switch label: 'whole' translated; actionSelector: #duration:onOff:; arguments: #(1)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. durRow addMorphBack: (switch label: 'half' translated; actionSelector: #duration:onOff:; arguments: #(2)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. durRow addMorphBack: (switch label: 'quarter' translated; actionSelector: #duration:onOff:; arguments: #(4)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. durRow addMorphBack: (switch label: 'eighth' translated; actionSelector: #duration:onOff:; arguments: #(8)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. durRow addMorphBack: (switch label: 'sixteenth' translated; actionSelector: #duration:onOff:; arguments: #(16)). self addMorph: durRow. durRow align: durRow fullBounds topCenter with: playRow fullBounds bottomCenter. "Add note duration modifier buttons" modRow _ AlignmentMorph newRow. modRow color: color; borderWidth: 0; layoutInset: 0. modRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. modRow addMorphBack: (switch label: 'dotted' translated; actionSelector: #durMod:onOff:; arguments: #(dotted)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. modRow addMorphBack: (switch label: 'normal' translated; actionSelector: #durMod:onOff:; arguments: #(normal)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. modRow addMorphBack: (switch label: 'triplets' translated; actionSelector: #durMod:onOff:; arguments: #(triplets)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. modRow addMorphBack: (switch label: 'quints' translated; actionSelector: #durMod:onOff:; arguments: #(quints)). self addMorph: modRow. modRow align: modRow fullBounds topCenter with: durRow fullBounds bottomCenter. "Add articulation buttons" articRow _ AlignmentMorph newRow. articRow color: color; borderWidth: 0; layoutInset: 0. articRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. articRow addMorphBack: (switch label: 'legato' translated; actionSelector: #articulation:onOff:; arguments: #(legato)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. articRow addMorphBack: (switch label: 'normal' translated; actionSelector: #articulation:onOff:; arguments: #(normal)). switch _ SimpleSwitchMorph new target: self; borderWidth: 2; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); setSwitchState: false. articRow addMorphBack: (switch label: 'staccato' translated; actionSelector: #articulation:onOff:; arguments: #(staccato)). self addMorph: articRow. articRow align: articRow fullBounds topCenter with: modRow fullBounds bottomCenter. self bounds: (self fullBounds expandBy: (0@0 extent: 0@borderWidth)) ! ! !KeyboardMorphForInput methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:55'! initialize "initialize the state of the receiver" super initialize. "" buildingChord _ false. self addRecordingControls. self duration: 4 onOff: true. self durMod: #normal onOff: true. self articulation: #normal onOff: true. insertMode _ false! ! !KeyboardMorphForInput methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:27'! mouseDownPitch: midiKey event: event noteMorph: keyMorph | sel noteEvent | event hand hasSubmorphs ifTrue: [^ self "no response if drag something over me"]. keyMorph color: playingKeyColor. (sel _ pianoRoll selection) ifNil: [^ self]. insertMode ifTrue: [sel _ pianoRoll selectionForInsertion. insertMode _ false]. sel = prevSelection ifFalse: ["This is a new selection -- need to determine start time" sel third = 0 ifTrue: [startOfNextNote _ 0] ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first) at: sel third) endTime. startOfNextNote _ startOfNextNote + self fullDuration - 1 truncateTo: self fullDuration]]. noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration; key: midiKey + 23 velocity: self velocity channel: 1. pianoRoll appendEvent: noteEvent fullDuration: self fullDuration. soundPlaying ifNotNil: [soundPlaying stopGracefully]. (soundPlaying _ self soundForEvent: noteEvent inTrack: sel first) play. prevSelection _ pianoRoll selection. startOfNextNote _ startOfNextNote + self fullDuration.! ! !KeyboardMorphForInput methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:28'! mouseUpPitch: pitch event: event noteMorph: noteMorph noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). ! ! !KeyedIdentitySet methodsFor: 'private' stamp: 'ajh 12/10/2000 20:24'! scanFor: anObject "Same as super except change = to ==, and hash to identityHash" | element start finish | start _ (anObject identityHash \\ array size) + 1. finish _ array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [(keyBlock value: element) == anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !KeyedSet methodsFor: 'adding' stamp: 'ajh 12/4/2001 05:35'! add: newObject "Include newObject as one of the receiver's elements, but only if not already present. Answer newObject." | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index _ self findElementOrNil: (keyBlock value: newObject). (array at: index) ifNotNil: [^ self errorKeyAlreadyExists: (array at: index)]. self atNewIndex: index put: newObject. ^ newObject! ! !KeyedSet methodsFor: 'adding' stamp: 'ajh 12/4/2001 05:27'! addAll: aCollection "Include all the elements of aCollection as the receiver's elements" (aCollection respondsTo: #associationsDo:) ifTrue: [aCollection associationsDo: [:ass | self add: ass]] ifFalse: [aCollection do: [:each | self add: each]]. ^ aCollection! ! !KeyedSet methodsFor: 'adding' stamp: 'ajh 6/3/2002 10:11'! member: newObject "Include newObject as one of the receiver's elements, if already exists just return it" | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index _ self findElementOrNil: (keyBlock value: newObject). (array at: index) ifNotNil: [^ array at: index]. self atNewIndex: index put: newObject. ^ newObject! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 3/29/2001 19:04'! errorKeyNotFound self error: 'key not found'! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:44'! fixCollisionsFrom: index "The element at index has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one" | length oldIndex newIndex element | oldIndex _ index. length _ array size. [oldIndex = length ifTrue: [oldIndex _ 1] ifFalse: [oldIndex _ oldIndex + 1]. (element _ self keyAt: oldIndex) == nil] whileFalse: [newIndex _ self findElementOrNil: (keyBlock value: element). oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 9/7/2001 11:56'! init: n super init: n. keyBlock _ [:element | element key]. ! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:46'! noCheckAdd: anObject array at: (self findElementOrNil: (keyBlock value: anObject)) put: anObject. tally _ tally + 1! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 12/13/2001 00:17'! rehash | newSelf | newSelf _ self species new: self size. newSelf keyBlock: keyBlock. self do: [:each | newSelf noCheckAdd: each]. array _ newSelf array! ! !KeyedSet methodsFor: 'private' stamp: 'ajh 9/5/2000 03:55'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start _ (anObject hash \\ array size) + 1. finish _ array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [(keyBlock value: element) = anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:57'! at: key "Answer the value associated with the key." ^ self at: key ifAbsent: [self errorKeyNotFound]! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 10/6/2000 20:28'! at: key ifAbsent: aBlock "Answer the value associated with the key or, if key isn't found, answer the result of evaluating aBlock." | obj | obj _ array at: (self findElementOrNil: key). obj ifNil: [^ aBlock value]. ^ obj! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 12/10/2000 15:42'! at: key ifAbsentPut: aBlock "Answer the value associated with the key or, if key isn't found, add the result of evaluating aBlock to self" ^ self at: key ifAbsent: [self add: aBlock value]! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 9/5/2000 03:58'! at: key ifPresent: aBlock "Lookup the given key in the receiver. If it is present, answer the value of evaluating the given block with the value associated with the key. Otherwise, answer nil." | v | v _ self at: key ifAbsent: [^ nil]. ^ aBlock value: v ! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:55'! keys | keys | keys _ Set new. self keysDo: [:key | keys add: key]. ^ keys! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 7/3/2004 17:54'! keysDo: block self do: [:item | block value: (keyBlock value: item)]! ! !KeyedSet methodsFor: 'accessing' stamp: 'ajh 5/11/2002 13:28'! keysSorted | keys | keys _ SortedCollection new. self do: [:item | keys add: (keyBlock value: item)]. ^ keys! ! !KeyedSet methodsFor: 'initialize' stamp: 'ajh 9/5/2000 03:36'! keyBlock: oneArgBlock "When evaluated return the key of the argument which will be an element of the set" keyBlock _ oneArgBlock! ! !KeyedSet methodsFor: 'removing' stamp: 'ajh 9/5/2000 03:47'! remove: oldObject ifAbsent: aBlock | index | index _ self findElementOrNil: (keyBlock value: oldObject). (array at: index) == nil ifTrue: [ ^ aBlock value ]. array at: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^ oldObject! ! !KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'! removeKey: key ^ self removeKey: key ifAbsent: [self errorKeyNotFound]! ! !KeyedSet methodsFor: 'removing' stamp: 'ajh 3/29/2001 19:03'! removeKey: key ifAbsent: aBlock | index obj | index _ self findElementOrNil: key. (obj _ array at: index) == nil ifTrue: [ ^ aBlock value ]. array at: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^ obj! ! !KeyedSet methodsFor: 'testing' stamp: 'ajh 9/5/2000 03:45'! includes: anObject ^ (array at: (self findElementOrNil: (keyBlock value: anObject))) ~~ nil! ! !KeyedSet methodsFor: 'testing' stamp: 'ajh 3/29/2001 23:56'! includesKey: key ^ (array at: (self findElementOrNil: key)) ~~ nil! ! !KeyedSet methodsFor: 'copying' stamp: 'ajh 9/5/2000 03:56'! copy ^super copy postCopyBlocks! ! !KeyedSet methodsFor: 'copying' stamp: 'ajh 9/5/2000 03:56'! postCopyBlocks keyBlock _ keyBlock copy. "Fix temps in case we're referring to outside stuff" keyBlock fixTemps.! ! !KeyedSet commentStamp: '<historical>' prior: 0! Like Set except a key of every element is used for hashing and searching instead of the element itself. keyBlock gets the key of an element.! !KeyedSet class methodsFor: 'instance creation' stamp: 'ajh 10/23/2000 23:16'! keyBlock: oneArgBlock "Create a new KeySet whose way to access an element's key is by executing oneArgBlock on the element" ^ self new keyBlock: oneArgBlock! ! !KidNavigationMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2003 18:39'! balloonText ^ ((mouseInside ifNil: [false]) ifTrue: ['Click here to see FEWER buttons.'] ifFalse: ['Click here to see MORE buttons.']) translated! ! !KidNavigationMorph methodsFor: 'as yet unclassified' stamp: 'nk 7/12/2003 08:46'! fontForButtons ^Preferences standardEToysFont! ! !KidNavigationMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:35'! defaultColor "answer the default color/fill style for the receiver" | result | result _ GradientFillStyle ramp: {0.0 -> (Color r: 0.032 g: 0.0 b: 0.484). 1.0 -> (Color r: 0.194 g: 0.032 b: 1.0)}. result origin: self bounds topLeft. result direction: 0 @ 200. result radial: false. ^ result! ! !KidNavigationMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:35'! initialize "initialize the state of the receiver" | | super initialize. "" self layoutInset: 12. self removeAllMorphs. self addButtons! ! !KlattFrameMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:35'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.452 g: 0.935 b: 0.548! ! !KlattFrameMorph methodsFor: 'initialization' stamp: 'nk 2/19/2004 16:55'! initialize super initialize. self listDirection: #topToBottom. self layoutInset: 6; cellInset: 4. self hResizing: #shrinkWrap; vResizing: #shrinkWrap.! ! !KlattFrameMorph methodsFor: 'initialization' stamp: 'nk 2/19/2004 16:58'! newSliderForParameter: parameter target: target min: min max: max description: description | r slider m | r _ AlignmentMorph newRow. r color: self color; borderWidth: 0; layoutInset: 0. r hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@20; wrapCentering: #center; cellPositioning: #leftCenter; cellInset: 4@0. slider _ SimpleSliderMorph new color: (Color r: 0.065 g: 0.548 b: 0.645); extent: 120@2; target: target; actionSelector: (parameter, ':') asSymbol; minVal: min; maxVal: max; adjustToValue: (target perform: parameter asSymbol). r addMorphBack: slider. m _ StringMorph new contents: parameter, ': '; hResizing: #rigid. r addMorphBack: m. m _ UpdatingStringMorph new target: target; getSelector: parameter asSymbol; putSelector: (parameter, ':') asSymbol; width: 60; growable: false; floatPrecision: (max - min / 100.0 min: 1.0); vResizing: #spaceFill; step. r addMorphBack: m. r setBalloonText: description. ^ r! ! !KlattResonatorIndices class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 20:17'! initialize "KlattResonatorIndices initialize" Rnpp := 1. Rtpp := 2. R1vp := 3. R2vp := 4. R3vp := 5. R4vp := 6. R2fp := 7. R3fp := 8. R4fp := 9. R5fp := 10. R6fp := 11. R1c := 12. R2c := 13. R3c := 14. R4c := 15. R5c := 16. R6c := 17. R7c := 18. R8c := 19. Rnpc := 20. Rnz := 21. Rtpc := 22. Rtz := 23. Rout := 24.! ! !KlattSynthesizer methodsFor: 'processing' stamp: 'ar 3/21/2001 12:21'! synthesizeFrame: aKlattFrame into: aSoundBuffer startingAt: index <primitive: 'primitiveSynthesizeFrameIntoStartingAt' module: 'Klatt'> ^(Smalltalk at: #KlattSynthesizerPlugin ifAbsent:[^self primitiveFail]) doPrimitive: 'primitiveSynthesizeFrameIntoStartingAt'! ! !KlattSynthesizer class methodsFor: 'class initialization' stamp: 'ar 5/18/2003 20:18'! initialize " KlattSynthesizer initialize " Epsilon _ 1.0e-04. ! ! !KoreanEnvironment methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 15:46'! beCurrentNaturalLanguage super beCurrentNaturalLanguage. Preferences restoreDefaultFontsForJapanese. ! ! !KoreanEnvironment commentStamp: '<historical>' prior: 0! This class provides the Korean support. Unfortunately, we haven't tested this yet. We did have a working version in previous implementations, but not this new implementation. But as soon as we find somebody who understand the language, probably we can make it work in two days or so, as we have done for Czech support.! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2004 14:53'! beCurrentNaturalLanguage super beCurrentNaturalLanguage. Preferences restoreDefaultFontsForJapanese. ! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:45'! clipboardInterpreterClass | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^NoConversionClipboardInterpreter]. platformName = 'Win32' ifTrue: [^WinKSX1001ClipboardInterpreter]. platformName = 'Mac OS' ifTrue: [('10*' match: SmalltalkImage current osVersion) ifTrue: [^NoConversionClipboardInterpreter] ifFalse: [^WinKSX1001ClipboardInterpreter]]. platformName = 'unix' ifTrue: [(ShiftJISTextConverter encodingNames includes: X11Encoding getEncoding) ifTrue: [^WinKSX1001ClipboardInterpreter] ifFalse: [^NoConversionClipboardInterpreter]]. ^NoConversionClipboardInterpreter! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:45'! defaultEncodingName | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. (#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) ifTrue: [^'euc-kr' copy]. (#('unix') includes: platformName) ifTrue: [^'euc-kr' copy]. ^'mac-roman'! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:46'! inputInterpreterClass | platformName osVersion encoding | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^MacRomanInputInterpreter]. platformName = 'Win32' ifTrue: [^WinKSX1001InputInterpreter]. platformName = 'Mac OS' ifTrue: [('10*' match: SmalltalkImage current osVersion) ifTrue: [^MacUnicodeInputInterpreter] ifFalse: [^WinKSX1001InputInterpreter]]. platformName = 'unix' ifTrue: [encoding := X11Encoding encoding. (EUCJPTextConverter encodingNames includes: encoding) ifTrue: [^MacRomanInputInterpreter]. (UTF8TextConverter encodingNames includes: encoding) ifTrue: [^MacRomanInputInterpreter]. (ShiftJISTextConverter encodingNames includes: encoding) ifTrue: [^MacRomanInputInterpreter]]. ^MacRomanInputInterpreter! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2004 14:50'! traditionalCharsetClass ^ KSX1001. ! ! !KoreanEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 18:42'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('ko' )! ! !LRUCache methodsFor: 'accessing' stamp: 'dgd 2/6/2002 21:43'! at: aKey "answer the object for aKey, if not present in the cache creates it" | element keyHash | calls _ calls + 1. keyHash _ aKey hash. 1 to: size do: [:index | element _ values at: index. (keyHash = (element at: 2) and: [aKey = (element at: 1)]) ifTrue: ["Found!!" hits _ hits + 1. values replaceFrom: 2 to: index with: (values first: index - 1). values at: 1 put: element. ^ element at: 3]]. "Not found!!" element _ {aKey. keyHash. factory value: aKey}. values replaceFrom: 2 to: size with: values allButLast. values at: 1 put: element. ^ element at: 3! ! !LRUCache methodsFor: 'initialization' stamp: 'dgd 3/28/2003 19:42'! initializeSize: aNumber factory: aBlock "initialize the receiver's size and factory" size := aNumber. values := Array new: aNumber withAll: {nil. nil. nil}. factory := aBlock. calls := 0. hits := 0! ! !LRUCache methodsFor: 'printing' stamp: 'dgd 3/28/2003 19:41'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." aStream nextPutAll: self class name; nextPutAll: ' size:'; nextPutAll: size asString; nextPutAll: ', calls:'; nextPutAll: calls asString; nextPutAll: ', hits:'; nextPutAll: hits asString; nextPutAll: ', ratio:'; nextPutAll: (hits / calls) asFloat asString! ! !LRUCache commentStamp: '<historical>' prior: 0! I'm a cache of values, given a key I return a Value from the cache or from the factory! !LRUCache class methodsFor: 'instance creation' stamp: 'dgd 3/26/2003 22:29'! size: aNumber factory: aBlock "answer an instance of the receiver" ^ self new initializeSize: aNumber factory: aBlock! ! !LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'! test " LRUCache test " | c | c := LRUCache size: 5 factory: [:key | key * 2]. c at: 1. c at: 2. c at: 3. c at: 4. c at: 1. c at: 5. c at: 6. c at: 7. c at: 8. c at: 1. ^ c! ! !LRUCache class methodsFor: 'testing' stamp: 'dgd 3/26/2003 22:22'! test2 " LRUCache test2. Time millisecondsToRun:[LRUCache test2]. MessageTally spyOn:[LRUCache test2]. " | c | c := LRUCache size: 600 factory: [:key | key * 2]. 1 to: 6000 do: [:each | c at: each]. ^ c! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 2/17/2005 18:23'! addTranslation "translate a phrase" | phrase | phrase := FillInTheBlank request: 'enter the original:' initialAnswer: ''. (phrase isNil or: [phrase = '']) ifTrue: ["" self beep. ^ self]. "" self translatePhrase: phrase! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 16:55'! applyTranslations "private - try to apply the translations as much as possible all over the image" Project current updateLocaleDependents! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/30/2004 22:25'! browseMethodsWithTranslation | translation | self selectedTranslation isZero ifTrue: ["" self beep. self inform: 'select the translation to look for' translated. ^ self]. "" translation := self translations at: self selectedTranslation. self systemNavigation browseMethodsWithLiteral: translation! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 7/13/2004 10:19'! browseMethodsWithUntranslated | untranslated | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untranslated phrase to look for' translated. ^ self]. "" untranslated := self untranslated at: self selectedUntranslated. SystemNavigation default browseMethodsWithLiteral: untranslated. ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 15:01'! codeSelectedTranslation | keys code | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys]. (StringHolder new contents: code) openLabel: 'exported codes'! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:27'! codeSelectedTranslationAsMimeString | keys code tmpStream s2 gzs cont | keys := selectedTranslations collect: [:key | self translations at: key]. code := String streamContents: [:aStream | self translator fileOutOn: aStream keys: keys]. tmpStream _ MultiByteBinaryOrTextStream on: ''. tmpStream converter: UTF8TextConverter new. tmpStream nextPutAll: code. s2 _ RWBinaryOrTextStream on: ''. gzs := GZipWriteStream on: s2. tmpStream reset. gzs nextPutAll: (tmpStream binary contentsOfEntireFile asString) contents. gzs close. s2 reset. cont _ String streamContents: [:strm | strm nextPutAll: 'NaturalLanguageTranslator loadForLocaleIsoString: '. strm nextPut: $'. strm nextPutAll: translator localeID isoString. strm nextPut: $'. strm nextPutAll: ' fromGzippedMimeLiteral: '. strm nextPut: $'. strm nextPutAll: (Base64MimeConverter mimeEncode: s2) contents. strm nextPutAll: '''.!!'. strm cr. ]. (StringHolder new contents: cont) openLabel: 'exported codes in Gzip+Base64 encoding'! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:27'! deselectAllTranslation selectedTranslations := IdentitySet new. self changed: #allSelections! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:14'! filterTranslations | filter | filter := FillInTheBlank request: 'filter with (empty string means no-filtering)' translated initialAnswer: self translationsFilter. "" self filterTranslations: filter! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:12'! filterTranslations: aString | filter | filter := aString ifNil:['']. "" translationsFilter _ filter. self update: #translations. ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:20'! filterUntranslated | filter | filter := FillInTheBlank request: 'filter with (empty string means no-filtering)' translated initialAnswer: self untranslatedFilter. "" self filterUntranslated: filter! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:20'! filterUntranslated: aString | filter | filter := aString ifNil: ['']. "" untranslatedFilter := filter. self update: #untranslated! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'tak 1/4/2005 09:24'! getTextExport (Smalltalk at: #GetTextExporter) new export: self model! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'! loadFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self changed: #translations. self changed: #untranslated]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:56'! mergeFromFile | fileName | fileName := self selectTranslationFileName. fileName isNil ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator loadFromFileNamed: fileName. self changed: #translations. self changed: #untranslated]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:32'! phrase: phraseString translation: translationString "set the models's translation for phraseString" self translator phrase: phraseString translation: translationString. self changed: #translations. self changed: #untranslated. newerKeys add: phraseString. ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 21:53'! phraseToTranslate "answer a phrase to translate. use the selected untranslated phrase or ask for a new one" ^ self selectedUntranslated isZero ifTrue: [FillInTheBlank multiLineRequest: 'new phrase to translate' translated centerAt: Sensor cursorPoint initialAnswer: '' answerHeight: 200] ifFalse: [self untranslated at: self selectedUntranslated]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 1/14/2005 18:00'! removeTranslation "remove the selected translation" | translation | self selectedTranslation isZero ifTrue: ["" self beep. self inform: 'select the translation to remove' translated. ^ self]. "" translation := self translations at: self selectedTranslation. "" (self confirm: ('Removing "{1}". Are you sure you want to do this?' translated format: {translation})) ifFalse: [^ self]. "" self translator removeTranslationFor: translation. self changed: #translations. self changed: #untranslated.! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 09:59'! removeUntranslated "remove the selected untranslated phrase" | untranslated | self selectedUntranslated isZero ifTrue: ["" self beep. self inform: 'select the untranslated phrase to remove' translated. ^ self]. "" untranslated := self untranslated at: self selectedUntranslated. "" (self confirm: ('Removing "{1}". Are you sure you want to do this?' translated format: {untranslated})) ifFalse: [^ self]. "" self translator removeUntranslated: untranslated! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 7/21/2004 19:27'! report self reportString openInWorkspaceWithTitle: 'report' translated! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:36'! resetNewerKeys self initializeNewerKeys. ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/9/2004 18:39'! saveToFile "save the translator to a file" | fileName | fileName := FillInTheBlank request: 'file name' translated initialAnswer: translator localeID isoString , '.translation'. (fileName isNil or: [fileName isEmpty]) ifTrue: ["" self beep. ^ self]. "" Cursor wait showWhile: [ self translator saveToFileNamed: fileName]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:40'! searchTranslation | search | search := FillInTheBlank request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: ["" self beep. ^ self]. "" self searchTranslation: search! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 10:00'! searchTranslation: aString | translations results index | translations := self translations. results := translations select: [:each | "" ('*' , aString , '*' match: each) or: ['*' , aString , '*' match: (self translator translationFor: each)]]. "" results isEmpty ifTrue: ["" self inform: 'no matches for' translated , ' ''' , aString , ''''. ^ self]. "" results size = 1 ifTrue: ["" self selectTranslationPhrase: results first. ^ self]. "" index := (PopUpMenu labelArray: (results collect: [:each | "" (each copy replaceAll: Character cr with: $\) , ' -> ' , ((self translator translationFor: each) copy replaceAll: Character cr with: $\)])) startUpWithCaption: 'select the translation...' translated. "" index isZero ifTrue: ["" self beep. ^ self]. "" self selectTranslationPhrase: (results at: index)! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/27/2003 20:42'! searchUntranslated | search | search := FillInTheBlank request: 'search for' translated initialAnswer: ''. (search isNil or: [search isEmpty]) ifTrue: ["" self beep. ^ self]. "" self searchUntranslated: search! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/1/2003 14:28'! searchUntranslated: aString | untranslateds results index | untranslateds := self untranslated. results := untranslateds select: [:each | '*' , aString , '*' match: each]. "" results isEmpty ifTrue: ["" self inform: 'no matches for' translated , ' ''' , aString , ''''. ^ self]. "" results size = 1 ifTrue: ["" self selectUntranslatedPhrase: results first. ^ self]. "" index := (PopUpMenu labelArray: (results collect: [:each | each copy replaceAll: Character cr with: $\])) startUpWithCaption: 'select the untranslated phrase...' translated. "" index isZero ifTrue: ["" self beep. ^ self]. "" self selectUntranslatedPhrase: (results at: index)! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'tak 11/28/2004 14:26'! selectAllTranslation selectedTranslations := (1 to: self translations size) asIdentitySet. self changed: #allSelections! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:40'! selectNewerKeys | translations index | self deselectAllTranslation. translations _ self translations. newerKeys do: [:k | index _ translations indexOf: k ifAbsent: [0]. index > 0 ifTrue: [ self selectedTranslationsAt: index put: true ]. ]. ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:15'! selectTranslationFileName "answer a file with a translation" | file | file := (StandardFileMenu oldFileMenu: FileDirectory default withPattern: '*.translation') startUpWithCaption: 'Select the file...' translated. ^ file isNil ifFalse: [file directory fullNameFor: file name]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 22:49'! selectTranslationPhrase: phraseString self selectedTranslation: (self translations indexOf: phraseString)! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/27/2003 20:43'! selectUntranslatedPhrase: phraseString self selectedUntranslated: (self untranslated indexOf: phraseString)! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'mir 8/11/2004 10:00'! status "answer a status string" | translationsSize untranslatedSize | translationsSize := self translator translations size. untranslatedSize := self translator untranslated size. ^ 'ÆÀ {1} phrases ÆÀ {2} translated ÆÀ {3} untranslated ÆÀ' translated format: {translationsSize + untranslatedSize. translationsSize. untranslatedSize}! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 21:53'! translate "translate a phrase" | phrase | phrase := self phraseToTranslate. "" (phrase isNil or: [phrase = '']) ifTrue: ["" self beep. ^ self]. "" self translatePhrase: phrase! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 8/24/2003 21:55'! translatePhrase: aString "translate aString" | translation | translation := FillInTheBlank multiLineRequest: 'translation for: ' translated , '''' , aString , '''' centerAt: Sensor cursorPoint initialAnswer: aString answerHeight: 200. "" (translation isNil or: [translation = '']) ifTrue: ["" self beep. ^ self]. "" self phrase: aString translation: translation! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:09'! translationsFilterWording ^ (self translationsFilter isEmpty ifTrue: ['filter' translated] ifFalse: ['filtering: {1}' translated format:{self translationsFilter}]) ! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:00'! translationsKeystroke: aChar "Respond to a Command key in the translations list." aChar == $x ifTrue: [^ self removeTranslation]. aChar == $E ifTrue: [^ self browseMethodsWithTranslation]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'yo 3/1/2005 12:49'! translationsMenu: aMenu ^ aMenu add: 'remove (x)' translated action: #removeTranslation; add: 'where (E)' translated action: #browseMethodsWithTranslation; add: 'select all' translated action: #selectAllTranslation; add: 'deselect all' translated action: #deselectAllTranslation; add: 'select changed keys' translated action: #selectNewerKeys; add: 'export selection' translated action: #codeSelectedTranslation; add: 'export selection in do-it form' translated action: #codeSelectedTranslationAsMimeString; add: 'reset changed keys' translated action: #resetNewerKeys; yourself! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 9/21/2003 12:19'! untranslatedFilterWording ^ self untranslatedFilter isEmpty ifTrue: ['filter' translated] ifFalse: ['filtering: {1}' translated format: {self untranslatedFilter}]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'gm 8/30/2003 02:01'! untranslatedKeystroke: aChar "Respond to a Command key in the translations list." aChar == $t ifTrue: [^ self translate]. aChar == $E ifTrue: [^ self browseMethodsWithUntranslated]! ! !LanguageEditor methodsFor: 'gui methods' stamp: 'dgd 10/13/2003 18:30'! untranslatedMenu: aMenu ^ aMenu add: 'remove' translated action: #removeUntranslated; add: 'translate (t)' translated action: #translate; add: 'where (E)' translated action: #browseMethodsWithUntranslated; yourself! ! !LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'tak 11/15/2004 12:15'! createStatusbar "create the statusbar for the receiver" | statusbar | statusbar := self createRow. statusbar addMorph: ((UpdatingStringMorph on: self selector: #status) growable: true; useStringFormat; hResizing: #spaceFill; stepTime: 2000). ^ statusbar! ! !LanguageEditor methodsFor: 'initialization - statusbar' stamp: 'dgd 9/21/2003 11:39'! initializeStatusbar "initialize the receiver's statusbar" self addMorph: self createStatusbar frame: (0 @ 0.93 corner: 1 @ 1)! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:07'! createButtonLabel: aString action: actionSelector help: helpString "create a toolbar for the receiver" | button | button := SimpleButtonMorph new target: self; label: aString translated "font: Preferences standardButtonFont"; actionSelector: actionSelector; setBalloonText: helpString translated; color: translator defaultBackgroundColor twiceDarker; borderWidth: 2; borderColor: #raised. "" ^ button! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'mir 7/21/2004 18:01'! createMainToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" " toolbar addMorphBack: (self createUpdatingButtonWording: #debugWording action: #switchDebug help: 'Switch the debug flag')." toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'save' action: #saveToFile help: 'Save the translations to a file'). toolbar addMorphBack: (self createButtonLabel: 'load' action: #loadFromFile help: 'Load the translations from a file'). toolbar addMorphBack: (self createButtonLabel: 'merge' action: #mergeFromFile help: 'Merge the current translations with the translations in a file'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'apply' action: #applyTranslations help: 'Apply the translations as much as possible.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'check translations' action: #check help: 'Check the translations and report the results.'). toolbar addMorphBack: (self createButtonLabel: 'report' action: #report help: 'Create a report.'). toolbar addMorphBack: (self createButtonLabel: 'gettext export' action: #getTextExport help: 'Exports the translations in GetText format.'). "" ^ toolbar! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:46'! createRow "create a row" | row | row := AlignmentMorph newRow. row layoutInset: 3; wrapCentering: #center; cellPositioning: #leftCenter. "" ^ row! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'yo 2/17/2005 18:24'! createTranslationsToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" toolbar addMorphBack: (self createUpdatingButtonWording: #translationsFilterWording action: #filterTranslations help: 'Filter the translations list.'). toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'search' action: #searchTranslation help: 'Search for a translation containing...'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'remove' action: #removeTranslation help: 'Remove the selected translation. If none is selected, ask for the one to remove.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'where' action: #browseMethodsWithTranslation help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'r-unused' action: #removeTranslatedButUnusedStrings help: 'Remove all the strings that are not used by the system'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'add ' action: #addTranslation help: 'Add a new phrase'). ^ toolbar! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'sd 12/18/2004 18:10'! createUntranslatedToolbar "create a toolbar for the receiver" | toolbar | toolbar := self createRow. "" toolbar addMorphBack: (self createUpdatingButtonWording: #untranslatedFilterWording action: #filterUntranslated help: 'Filter the untranslated list.'). toolbar addTransparentSpacerOfSize: 5 @ 0. "" toolbar addMorphBack: (self createButtonLabel: 'search' action: #searchUntranslated help: 'Search for a untranslated phrase containing...'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'remove' action: #removeUntranslated help: 'Remove the selected untranslated phrease. If none is selected, ask for the one to remove.'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'translate' action: #translate help: 'Translate the selected untranslated phrase or a new phrase'). "" toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'where' action: #browseMethodsWithUntranslated help: 'Launch a browser on all methods that contain the phrase as a substring of any literal String.'). toolbar addTransparentSpacerOfSize: 5 @ 0. toolbar addMorphBack: (self createButtonLabel: 'r-unused' action: #removeUntranslatedButUnusedStrings help: 'Remove all the strings that are not used by the system'). ^ toolbar! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'tak 11/16/2004 15:06'! createUpdatingButtonWording: wordingSelector action: actionSelector help: helpString "create a toolbar for the receiver" | button | button := (UpdatingSimpleButtonMorph newWithLabel: '-') target: self; wordingSelector: wordingSelector; actionSelector: actionSelector; setBalloonText: helpString translated; color: translator defaultBackgroundColor twiceDarker; borderWidth: 1; borderColor: #raised; cornerStyle: #square. "" ^ button! ! !LanguageEditor methodsFor: 'initialization - toolbar' stamp: 'dgd 9/21/2003 11:27'! initializeToolbars "initialize the receiver's toolbar" self addMorph: self createMainToolbar frame: (0 @ 0 corner: 1 @ 0.09). "" self addMorph: self createTranslationsToolbar frame: (0 @ 0.09 corner: 0.5 @ 0.18). self addMorph: self createUntranslatedToolbar frame: (0.5 @ 0.09 corner: 1 @ 0.18)! ! !LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/28/2003 10:31'! okToChange "Allows a controller to ask this of any model" self selectedTranslation isZero ifTrue: [^ true]. "" translationText hasUnacceptedEdits ifFalse: [^ true]. ^ (CustomMenu confirm: 'Discard the changes to currently selected translated phrase?' translated) and: ["" translationText hasUnacceptedEdits: false. true]! ! !LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'! refreshTranslations "refresh the translations panel" self changed: #translations. self selectedTranslation: 0! ! !LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/27/2003 19:59'! refreshUntranslated "refresh the untranslated panel" self changed: #untranslated. self selectedUntranslated: 0! ! !LanguageEditor methodsFor: 'updating' stamp: 'dgd 8/25/2003 20:11'! update: aSymbol "Receive a change notice from an object of whom the receiver is a dependent." super update: aSymbol. "" aSymbol == #untranslated ifTrue: [self refreshUntranslated]. aSymbol == #translations ifTrue: [self refreshTranslations]! ! !LanguageEditor methodsFor: 'initialization' stamp: 'yo 3/1/2005 12:33'! initializeNewerKeys newerKeys _ Set new. ! ! !LanguageEditor methodsFor: 'initialization' stamp: 'yo 3/1/2005 12:33'! initializeOn: aLanguage "initialize the receiver on aLanguage" "" selectedTranslation := 0. selectedUntranslated := 0. selectedTranslations := IdentitySet new. "" translator := aLanguage. "" self setLabel: 'Language editor for: ' translated , self translator name. "" self initializeToolbars. self initializePanels. self initializeStatusbar. self initializeNewerKeys. ! ! !LanguageEditor methodsFor: 'initialization' stamp: 'tak 11/28/2004 14:12'! initializePanels "initialize the receiver's panels" translationsList := PluggableListMorphOfMany on: self list: #translations primarySelection: #selectedTranslation changePrimarySelection: #selectedTranslation: listSelection: #selectedTranslationsAt: changeListSelection: #selectedTranslationsAt:put: menu: #translationsMenu: keystroke: #translationsKeystroke:. translationsList setBalloonText: 'List of all the translated phrases.' translated. "" untranslatedList := PluggableListMorph on: self list: #untranslated selected: #selectedUntranslated changeSelected: #selectedUntranslated: menu: #untranslatedMenu: keystroke: #untranslatedKeystroke:. untranslatedList setBalloonText: 'List of all the untranslated phrases.' translated. "" translationText := PluggableTextMorph on: self text: #translation accept: #translation: readSelection: nil menu: nil. translationText setBalloonText: 'Translation for the selected phrase in the upper list.' translated. "" self addMorph: translationsList frame: (0 @ 0.18 corner: 0.5 @ 0.66). self addMorph: untranslatedList frame: (0.5 @ 0.18 corner: 1 @ 0.93). self addMorph: translationText frame: (0 @ 0.66 corner: 0.5 @ 0.93)! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 19:13'! selectedTranslation "answer the selectedTranslation" ^ selectedTranslation! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:56'! selectedTranslation: anInteger "change the receiver's selectedTranslation" selectedTranslation := anInteger. "" self changed: #selectedTranslation. self changed: #translation! ! !LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:12'! selectedTranslationsAt: index ^ selectedTranslations includes: index! ! !LanguageEditor methodsFor: 'accessing' stamp: 'tak 11/28/2004 14:15'! selectedTranslationsAt: index put: value value = true ifTrue: [selectedTranslations add: index] ifFalse: [selectedTranslations remove: index ifAbsent: []]! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'! selectedUntranslated "answer the selectedUntranslated" ^ selectedUntranslated! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 8/24/2003 21:57'! selectedUntranslated: anInteger "change the selectedUntranslated" selectedUntranslated := anInteger. "" self changed: #selectedUntranslated! ! !LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! translation "answer the translation for the selected phrase" self selectedTranslation isZero ifTrue: [^ '<select a phrase from the upper list>' translated]. "" ^ self translator translationFor: (self translations at: self selectedTranslation)! ! !LanguageEditor methodsFor: 'accessing' stamp: 'yo 3/1/2005 12:44'! translation: aStringOrText "change the translation for the selected phrase" | phrase | self selectedTranslation isZero ifTrue: [^ self]. phrase _ self translations at: self selectedTranslation. translator phrase: phrase translation: aStringOrText asString. newerKeys add: phrase. ^ true! ! !LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! translations "answet the translator's translations" | allTranslations filterString | allTranslations := self translator translations keys. "" filterString := self translationsFilter. "" filterString isEmpty ifFalse: [allTranslations := allTranslations select: [:each | "" ('*' , filterString , '*' match: each) or: ['*' , filterString , '*' match: (self translator translationFor: each)]]]. "" ^ allTranslations asSortedCollection! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:00'! translationsFilter ^translationsFilter ifNil:['']! ! !LanguageEditor methodsFor: 'accessing' stamp: 'mir 8/11/2004 10:00'! untranslated "answer the translator's untranslated phrases" | all filterString | all := self translator untranslated. "" filterString := self untranslatedFilter. "" filterString isEmpty ifFalse: [all := all select: [:each | "" ('*' , filterString , '*' match: each) or: ['*' , filterString , '*' match: (self translator translationFor: each)]]]. "" ^ all asSortedCollection! ! !LanguageEditor methodsFor: 'accessing' stamp: 'dgd 9/21/2003 12:19'! untranslatedFilter ^ untranslatedFilter ifNil: ['']! ! !LanguageEditor methodsFor: 'message handling' stamp: 'gm 8/30/2003 01:54'! perform: selector orSendTo: otherTarget "I wish to intercept and handle selector myself" ^ self perform: selector! ! !LanguageEditor methodsFor: 'open/close' stamp: 'dgd 8/26/2003 14:20'! delete "Remove the receiver as a submorph of its owner" self model: nil. super delete ! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:24'! asHtml: aString | stream | stream := String new writeStream. aString do: [:each | each caseOf: { [Character cr] -> [stream nextPutAll: '<br>']. [$&] -> [stream nextPutAll: '&']. [$<] -> [stream nextPutAll: '<']. [$>] -> [stream nextPutAll: '>']. [$*] -> [stream nextPutAll: '☆']. [$@] -> [stream nextPutAll: '&at;']} otherwise: [stream nextPut: each]]. ^ stream contents! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 09:59'! printHeaderReportOn: aStream "append to aStream a header report of the receiver with swiki format" aStream nextPutAll: '!!!!'; nextPutAll: ('Language: {1}' translated format: {self translator localeID isoString}); cr. aStream nextPutAll: '- '; nextPutAll: ('{1} translated phrases' translated format: {self translator translations size}); cr. aStream nextPutAll: '- '; nextPutAll: ('{1} untranslated phrases' translated format: {self translator untranslated size}); cr. aStream cr; cr! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:25'! printReportOn: aStream "append to aStream a report of the receiver with swiki format" self printHeaderReportOn: aStream. self printUntranslatedReportOn: aStream. self printTranslationsReportOn: aStream! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 8/11/2004 10:01'! printTranslationsReportOn: aStream "append to aStream a report of the receiver's translations" | originalPhrases | aStream nextPutAll: '!!'; nextPutAll: 'translations' translated; cr. originalPhrases := self translator translations keys asSortedCollection. originalPhrases do: [:each | aStream nextPutAll: ('|{1}|{2}|' format: {self asHtml: each. self asHtml: (self translator translationFor: each)}); cr]. aStream cr; cr! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'! printUntranslatedReportOn: aStream "append to aStream a report of the receiver's translations" aStream nextPutAll: '!!'; nextPutAll: 'not translated' translated; cr. self untranslated asSortedCollection do: [:each | aStream nextPutAll: ('|{1}|' format: {self asHtml: each}); cr]. aStream cr; cr! ! !LanguageEditor methodsFor: 'reporting' stamp: 'mir 7/21/2004 19:26'! reportString "answer a string with a report of the receiver" | stream | stream := String new writeStream. self printReportOn: stream. ^ stream contents! ! !LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:58'! check "check the translations and answer a collection with the results" | results counter phrasesCount untranslated translations checkMethod | results := OrderedCollection new. untranslated := self translator untranslated. translations := self translator translations. phrasesCount := translations size + untranslated size. counter := 0. checkMethod := self class checkMethods at: self translator localeID printString ifAbsent: [^results]. translations keysAndValuesDo: [:phrase :translation | | result | result := self perform: checkMethod with: phrase with: translation. (result notNil and: [result notEmpty]) ifTrue: [results add: {phrase. translation. result}]. counter := counter + 1. (counter isDivisibleBy: 50) ifTrue: [| percent | percent := counter / phrasesCount * 100 roundTo: 0.01. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. untranslated do: [:phrase | | result | result := self checkUntranslatedPhrase: phrase. (result notNil and: [result notEmpty]) ifTrue: [results add: {phrase. nil. result}]. counter := counter + 1. (counter isDivisibleBy: 50) ifTrue: [| percent | percent := counter / phrasesCount * 100 roundTo: 0.01. Transcript show: ('- checked {1} phrases of {2} ({3}%)...' translated format: {counter. phrasesCount. percent}); cr]]. ^ results! ! !LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:58'! checkPhrase: phraseString translation: translationString ^nil! ! !LanguageEditor methodsFor: 'private' stamp: 'tak 12/26/2004 12:10'! checkSpanishPhrase: phraseString translation: translationString "check the translation an aswer a string with a comment or a nil meaning no-comments" | superResult | superResult := self checkPhrase: phraseString translation: translationString. superResult isNil ifFalse: [^ superResult]. "For some reason, MCInstaller couldn't read Spanish character." " ((translationString withBlanksTrimmed includes: $?) and: [(translationString withBlanksTrimmed includes: $é…) not]) ifTrue: [^ 'é…OlvidƧ el signo de pregunta?']. ((translationString withBlanksTrimmed includes: $!!) and: [(translationString withBlanksTrimmed includes: $éÄ) not]) ifTrue: [^ 'é…OlvidƧ el signo de admiraciƧn?']. " ^ nil! ! !LanguageEditor methodsFor: 'private' stamp: 'mir 7/21/2004 18:57'! checkUntranslatedPhrase: phraseString "check the phrase an aswer a string with a comment or a nil meaning no-comments" (self translations includes: phraseString) ifTrue: [^ 'possible double-translation' translated]. ^ nil! ! !LanguageEditor methodsFor: 'private' stamp: 'mir 8/11/2004 09:57'! translator ^translator! ! !LanguageEditor methodsFor: 'stef' stamp: 'sd 11/25/2004 09:32'! identifyUnusedStrings "self new identifyUnusedStrings" translationsList getList do: [:each | Transcript show: each. Transcript show: (Smalltalk allSelect: [:method | method hasLiteralSuchThat: [:lit | lit class == String and: [lit includesSubstring: each caseSensitive: true]]]) size printString; cr]! ! !LanguageEditor methodsFor: 'stef' stamp: 'sd 12/18/2004 18:15'! numberOfTimesStringIsUsed: aString ^ (self systemNavigation allSelect: [:method | method hasLiteralSuchThat: [:lit | lit class == String and: [lit includesSubstring: aString caseSensitive: true]]]) size! ! !LanguageEditor methodsFor: 'stef' stamp: 'tak 1/4/2005 09:26'! removeTranslatedButUnusedStrings (self confirm: 'Are you sure that you want to remove unused strings?' translated) ifFalse: [^ self]. translationsList getList do: [:each | | timesUsed | timesUsed := self numberOfTimesStringIsUsed: each. Transcript show: each. Transcript show: timesUsed printString; cr. timesUsed isZero ifTrue: [self translator removeTranslationFor: each]]! ! !LanguageEditor methodsFor: 'stef' stamp: 'yo 1/14/2005 16:55'! removeUntranslatedButUnusedStrings (self confirm: 'Are you sure that you want to remove unused strings?' translated) ifFalse: [^ self]. untranslatedList getList do: [:each | | timesUsed | timesUsed := self numberOfTimesStringIsUsed: each. Transcript show: each. Transcript show: timesUsed printString; cr. timesUsed isZero ifTrue: [self translator removeUntranslated: each]]. self update: #untranslated. ! ! !LanguageEditor commentStamp: 'dgd 11/16/2003 15:02' prior: 0! Editor for Babel's languages. Open it from World Menu >> open... >> Language Editor (to open on default language) World Menu >> open... >> Language Editor for... (to choose the language) Or click: LanguageEditor openOnDefault. LanguageEditor open. See http://swiki.agro.uba.ar/small_land/191 for documentation ! !LanguageEditor class methodsFor: 'private' stamp: 'mir 7/21/2004 18:47'! checkMethods ^CheckMethods ifNil: [CheckMethods := self initCheckMethods]! ! !LanguageEditor class methodsFor: 'private' stamp: 'dgd 11/9/2003 15:39'! ensureVisibilityOfWindow: aWindow "private - activate the window" | | aWindow expand. aWindow comeToFront. "" aWindow right: (aWindow right min: World right). aWindow bottom: (aWindow bottom min: World bottom). aWindow left: (aWindow left max: World left). aWindow top: (aWindow top max: World top). "" aWindow flash; flash! ! !LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 17:00'! on: aLanguage "answer an instance of the receiver on aLanguage" ^ self new initializeOn: (NaturalLanguageTranslator localeID: aLanguage)! ! !LanguageEditor class methodsFor: 'instance creation' stamp: 'mir 8/11/2004 10:00'! openOn: aLanguage "open an instance on aLanguage" World submorphs do: [:each | "" ((each isKindOf: LanguageEditor) and: [each translator == aLanguage]) ifTrue: ["" self ensureVisibilityOfWindow: each. ^ self]]. "" ^ (self on: aLanguage) openInWorld! ! !LanguageEditor class methodsFor: 'initialize-release' stamp: 'mir 7/21/2004 18:47'! initCheckMethods "LanguageEditor initCheckMethods" | registry | registry := Dictionary new. registry at: 'es' put: #checkSpanishPhrase:translation:; yourself. ^registry! ! !LanguageEditor class methodsFor: 'initialize-release' stamp: 'dgd 11/9/2003 14:27'! initialize "initialize the receiver" (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: ["" TheWorldMenu registerOpenCommand: {'Language Editor'. {self. #openOnDefault}}. TheWorldMenu registerOpenCommand: {'Language Editor for...'. {self. #open}}]! ! !LanguageEditor class methodsFor: 'initialize-release' stamp: 'dgd 11/9/2003 14:27'! unload "the receiver is being unloaded" (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: ["" TheWorldMenu unregisterOpenCommand: 'Language Editor'. TheWorldMenu unregisterOpenCommand: 'Language Editor for...'] ! ! !LanguageEditor class methodsFor: 'opening' stamp: 'mir 7/21/2004 16:57'! open "open the receiver on any language" " LanguageEditor open. " | menu | menu := MenuMorph new defaultTarget: self. menu addTitle: 'Language Editor for...' translated. "" (NaturalLanguageTranslator availableLanguageLocaleIDs asSortedCollection: [:x :y | x asString <= y asString]) do: [:eachLanguage | "" menu add: eachLanguage name target: self selector: #openOn: argument: eachLanguage]. "" menu popUpInWorld! ! !LanguageEditor class methodsFor: 'opening' stamp: 'mir 7/21/2004 16:59'! openOnDefault "open the receiver on the default language" self openOn: NaturalLanguageTranslator current! ! !LanguageEnvironment methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 15:46'! beCurrentNaturalLanguage ! ! !LanguageEnvironment methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 15:31'! localeID: anID id := anID! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! isoCountry ^self localeID isoCountry! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:32'! isoLanguage ^self localeID isoLanguage! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:55'! leadingChar ^self class leadingChar! ! !LanguageEnvironment methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:31'! localeID ^id! ! !LanguageEnvironment methodsFor: 'utilities' stamp: 'mir 7/21/2004 18:05'! checkPhrase: phrase translation: translation "check the translation. Answer a string with a comment or meaning no-comments" ^nil! ! !LanguageEnvironment commentStamp: '<historical>' prior: 0! The name multilingualized Squeak suggests that you can use multiple language at one time. This is true, of course, but the system still how to manage the primary language; that provides the interpretation of data going out or coming in from outside world. It also provides how to render strings, as there rendering rule could be different in one language to another, even if the code points in a string is the same. Originally, LanguageEnvironment and its subclasses only has class side methods. After merged with Diego's Babel work, it now has instance side methods. Since this historical reason, the class side and instance side are not related well. When we talk about the interface with the outside of the Squeak world, there are three different "channels"; the keyboard input, clipboard output and input, and filename. On a not-to-uncommon system such as a Unix system localized to Japan, all of these three can have (and does have) different encodings. So we need to manage them separately. Note that the encoding in a file can be anything. While it is nice to provide a suggested guess for this 'default system file content encoding', it is not critical. Rendering support is limited basic L-to-R rendering so far. But you can provide different line-wrap rule, at least. ! !LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 8/14/2003 15:39'! beCurrentNaturalLanguage ! ! !LanguageEnvironment class methodsFor: 'language methods' stamp: 'yo 1/18/2005 15:56'! scanSelector ^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern: ! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'yo 3/15/2004 21:15'! clearDefault ClipboardInterpreterClass _ nil. InputInterpreterClass _ nil. SystemConverterClass _ nil. FileNameConverterClass _ nil. ! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 15:54'! initialize "LanguageEnvironment initialize" Smalltalk addToStartUpList: LanguageEnvironment after: FileDirectory. Smalltalk addToStartUpList: FileDirectory after: LanguageEnvironment. ! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 16:13'! localeChanged self startUp! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/21/2004 19:10'! resetKnownEnvironments "LanguageEnvironment resetKnownEnvironments" KnownEnvironments := nil! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 15:54'! startUp self clearDefault. Current := nil. Clipboard startUp. HandMorph startUp. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! clipboardInterpreterClass self subclassResponsibility. ^ NoConversionClipboardInterpreter. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! fileNameConverterClass self subclassResponsibility. ^ Latin1TextConverter. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! inputInterpreterClass self subclassResponsibility. ^ MacRomanInputInterpreter. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:11'! leadingChar self subclassResponsibility. ^ 0. ! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'mir 7/1/2004 17:59'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." self subclassResponsibility! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! systemConverterClass self subclassResponsibility. ^ Latin1TextConverter. ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'! defaultClipboardInterpreter ClipboardInterpreterClass ifNil: [ClipboardInterpreterClass _ self currentPlatform class clipboardInterpreterClass]. ^ ClipboardInterpreterClass new. ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 3/15/2004 15:50'! defaultEncodingName ^ 'mac-roman'. ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'! defaultFileNameConverter FileNameConverterClass ifNil: [FileNameConverterClass := self currentPlatform class fileNameConverterClass]. ^ FileNameConverterClass new! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:36'! defaultInputInterpreter InputInterpreterClass ifNil: [InputInterpreterClass _ self inputInterpreterClass]. ^ InputInterpreterClass new. ! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'yo 7/28/2004 21:56'! defaultSystemConverter SystemConverterClass ifNil: [SystemConverterClass _ self currentPlatform class systemConverterClass]. ^ SystemConverterClass new. ! ! !LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 7/2/2004 17:57'! flapTabTextFor: aString "self subclassResponsibility." ^ aString. ! ! !LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 7/2/2004 17:57'! flapTabTextFor: aString in: aFlapTab "self subclassResponsibility." ^ aString. ! ! !LanguageEnvironment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 21:54'! isBreakableAt: index in: text | char | char _ text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. ^ false. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeGlobalVarInitial: char ^ Unicode canBeGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeNonGlobalVarInitial: char ^ Unicode canBeNonGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:39'! current "LanguageEnvironment current" ^Current ifNil: [ Current := Locale current languageEnvironment. Current beCurrentNaturalLanguage. ^Current]! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 7/28/2004 21:34'! currentPlatform ^ Locale currentPlatform languageEnvironment. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! digitValue: char ^ Unicode digitValue: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 12/2/2004 16:13'! isCharset ^ false. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! isDigit: char ^ Unicode isDigit: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isLetter: char ^ Unicode isLetter: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isLowercase: char ^ Unicode isLowercase: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isUppercase: char ^ Unicode isUppercase: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:45'! localeID: localeID ^self knownEnvironments at: localeID ifAbsentPut: [self new localeID]! ! !LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/21/2004 19:08'! initKnownEnvironments "LanguageEnvironment initKnownEnvironments" | env known | known := Dictionary new. self allSubclassesDo: [:subClass | subClass supportedLanguages do: [:language | env := subClass new. env localeID: (LocaleID isoString: language). known at: env localeID put: env]]. ^known! ! !LanguageEnvironment class methodsFor: 'private' stamp: 'mir 7/15/2004 15:45'! knownEnvironments "LanguageEnvironment knownEnvironments" "KnownEnvironments := nil" ^KnownEnvironments ifNil: [KnownEnvironments := self initKnownEnvironments]! ! !LargeNegativeIntegerTest methodsFor: 'testing' stamp: 'dtl 5/26/2004 18:34'! testEmptyTemplate "Check that an uninitialized instance behaves reasonably." | i | i _ LargeNegativeInteger new: 4. self assert: i size == 4. self assert: i printString = '-0'. self assert: i normalize == 0! ! !LargePositiveInteger methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! hash ^ByteArray hashBytes: self startingWith: self species hash! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'! as31BitSmallInt "This is only for 31 bit numbers. Keep my 31 bits the same, but put them in a small int. The small int will be negative since my 31st bit is 1. We know my 31st bit is 1 because otherwise I would already be a positive small int." self highBit = 31 ifFalse: [self error: 'more than 31 bits can not fit in a SmallInteger']. ^ self - 16r80000000! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'RAA 3/2/2002 14:32'! withAtLeastNDigits: desiredLength | new | self size >= desiredLength ifTrue: [^self]. new _ self class new: desiredLength. new replaceFrom: 1 to: self size with: self startingAt: 1. ^new! ! !LargePositiveIntegerTest methodsFor: 'testing' stamp: 'md 3/17/2003 15:20'! testBitShift "Check bitShift from and back to SmallInts" 1 to: 257 do: [:i | self should: [((i bitShift: i) bitShift: 0-i) == i]].! ! !LargePositiveIntegerTest methodsFor: 'testing' stamp: 'dtl 5/26/2004 18:33'! testEmptyTemplate "Check that an uninitialized instance behaves reasonably." | i | i _ LargePositiveInteger new: 4. self assert: i size == 4. self assert: i printString = '0'. self assert: i normalize == 0! ! !LargePositiveIntegerTest methodsFor: 'testing' stamp: 'md 3/17/2003 15:17'! testMultDicAddSub | n f f1 | n _ 100. f _ 100 factorial. f1 _ f*(n+1). n timesRepeat: [f1 _ f1 - f]. self should: [f1 = f]. n timesRepeat: [f1 _ f1 + f]. self should: [f1 // f = (n+1)]. self should: [f1 negated = (Number readFrom: '-' , f1 printString)].! ! !LargePositiveIntegerTest methodsFor: 'testing' stamp: 'md 3/17/2003 15:19'! testNormalize "Check normalization and conversion to/from SmallInts" self should: [(SmallInteger maxVal + 1 - 1) == SmallInteger maxVal]. self should: [(SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3)]. self should: [(SmallInteger minVal - 1 + 1) == SmallInteger minVal]. self should: [(SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3)].! ! !LassoPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:43'! initialize "Initialize the receiver. Sets its image to the lasso picture" super initialize. self image: (ScriptingSystem formAtKey: 'Lasso')! ! !LassoPatchMorph methodsFor: 'initialization' stamp: 'sw 7/5/2004 01:44'! initializeToStandAlone "Initialize the receiver such that it can live on its own. Sets its image to the lasso picture" super initializeToStandAlone. self image: (ScriptingSystem formAtKey: 'Lasso')! ! !LassoPatchMorph methodsFor: 'misc' stamp: 'sw 7/5/2004 01:50'! isCandidateForAutomaticViewing "Answer whether the receiver is a candidate for automatic viewing. Only relevant if a now-seldom-used feature, automaticViewing, is in play" ^ self isPartsDonor not! ! !LassoPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 15:43'! justDroppedInto: aPasteUpMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph" aPasteUpMorph isPartsBin ifFalse: [self delete. ActiveWorld displayWorldSafely; runStepMethods. ^ aPasteUpMorph grabLassoFromScreen: anEvent]. ^ super justDroppedInto: aPasteUpMorph event: anEvent! ! !LassoPatchMorph methodsFor: 'dropping' stamp: 'sw 4/6/2004 13:19'! wantsToBeDroppedInto: aMorph "Only into PasteUps that are not part bins" ^ aMorph isPlayfieldLike! ! !LassoPatchMorph commentStamp: 'sw 8/1/2004 13:27' prior: 0! When dropped by the user, a cursor is presented, allowing the user to grab a rectangular patch from the screen.! !LassoPatchMorph class methodsFor: 'parts bin' stamp: 'sw 7/5/2004 01:46'! descriptionForPartsBin "Answer a description of the receiver to be used in a parts bin" ^ self partName: 'Lasso' categories: #('Graphics') documentation: 'Drop this icon to grab a patch from the screen with a lasso.'! ! !LassoPatchMorph class methodsFor: 'instance creation' stamp: 'sw 7/5/2004 01:53'! authoringPrototype "Answer a prototype for use in a parts bin" ^ self new image: (ScriptingSystem formAtKey: 'Lasso'); markAsPartsDonor; setBalloonText: 'Drop this on the desktop and you can then grab a patch from the screen with a lasso.'; yourself! ! !Latin1 commentStamp: 'yo 10/19/2004 19:53' prior: 0! This class represents the domestic character encoding called ISO-8859-1, also known as Latin-1 used for Most of the Western European Languages.! !Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:46'! emitSequenceToResetStateIfNeededOn: aStream forState: state (state g0Leading ~= 0) ifTrue: [ state charSize: 1. state g0Leading: 0. state g0Size: 1. aStream basicNextPutAll: CompoundTextSequence. ]. "Actually, G1 state should go back to ISO-8859-1, too." ! ! !Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:41'! initialize " self initialize " CompoundTextSequence _ String streamContents: [:s | s nextPut: (Character value: 27). s nextPut: $(. s nextPut: $B. ]. RightHalfSequence _ String streamContents: [:s | s nextPut: (Character value: 27). s nextPut: $-. s nextPut: $A. ]. ! ! !Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:32'! leadingChar ^ 0. ! ! !Latin1 class methodsFor: 'class methods' stamp: 'yo 8/18/2003 17:41'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state (ascii <= 16r7F and: [state g0Leading ~= 0]) ifTrue: [ state charSize: 1. state g0Leading: 0. state g0Size: 1. aStream basicNextPutAll: CompoundTextSequence. aStream basicNextPut: (Character value: ascii). ^ self. ]. ((16r80 <= ascii and: [ascii <= 16rFF]) and: [state g1Leading ~= 0]) ifTrue: [ ^ self nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ]. aStream basicNextPut: (Character value: ascii). ^ self. ! ! !Latin1 class methodsFor: 'character classification' stamp: 'yo 8/28/2004 10:41'! isLetter: char "Answer whether the receiver is a letter." ^ Unicode isLetter: char. ! ! !Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! isBreakableAt: index in: text | char | char _ text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. ^ false. ! ! !Latin1 class methodsFor: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! printingDirection ^ #right. ! ! !Latin1 class methodsFor: 'private' stamp: 'yo 8/18/2003 17:41'! nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state state charSize: 1. state g1Leading: 0. state g1Size: 1. aStream basicNextPutAll: RightHalfSequence. aStream basicNextPut: (Character value: ascii). ! ! !Latin1Environment commentStamp: '<historical>' prior: 0! This class provides the support for the languages in 'Latin-1' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 3/17/2004 15:07'! beCurrentNaturalLanguage ! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state ^ self traditionalCharsetClass nextPutRightHalfValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 10:00'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state ^ self traditionalCharsetClass nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state.! ! !Latin1Environment class methodsFor: 'language methods' stamp: 'yo 1/24/2005 09:59'! traditionalCharsetClass ^ Latin1. ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'bf 10/6/2004 19:13'! clipboardInterpreterClass ^ MacRomanClipboardInterpreter! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'nk 7/30/2004 21:39'! defaultEncodingName | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. (#('Win32' 'Mac OS' 'ZaurusOS') includes: platformName) ifTrue: [^'iso8859-1' copy]. (#('unix') includes: platformName) ifTrue: [^'iso8859-1' copy]. ^'mac-roman'! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! fileNameConverterClass ^ Latin1TextConverter ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! inputInterpreterClass ^ MacRomanInputInterpreter. ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! leadingChar ^ 0. ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 2/24/2005 20:41'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('fr' 'es' 'ca' 'eu' 'pt' 'it' 'sq' 'rm' 'nl' 'de' 'da' 'sv' 'no' 'fi' 'fo' 'is' 'ga' 'gd' 'en' 'af' 'sw')! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! systemConverterClass ^ Latin1TextConverter. ! ! !Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:08'! flapTabTextFor: aString ^ aString. ! ! !Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:08'! flapTabTextFor: aString in: aFlapTab ^ aString. ! ! !Latin1Environment class methodsFor: 'rendering support' stamp: 'yo 3/17/2004 15:07'! isBreakableAt: index in: text | char | char _ text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. ^ false. ! ! !Latin1TextConverter methodsFor: 'conversion' stamp: 'yo 12/28/2003 01:14'! nextFromStream: aStream ^ aStream basicNext. ! ! !Latin1TextConverter methodsFor: 'conversion' stamp: 'yo 7/12/2004 10:57'! nextPut: aCharacter toStream: aStream aStream basicNextPut: (Character value: aCharacter charCode). ! ! !Latin1TextConverter methodsFor: 'friend' stamp: 'yo 12/28/2003 01:14'! currentCharSize ^ 1. ! ! !Latin1TextConverter commentStamp: '<historical>' prior: 0! Text converter for ISO 8859-1. An international encoding used in Western Europe.! !Latin1TextConverter class methodsFor: 'utilities' stamp: 'yo 12/28/2003 01:15'! encodingNames ^ #('latin-1' 'latin1') copy. ! ! !Latin2Environment commentStamp: '<historical>' prior: 0! This class provides the support for the languages in 'Latin-2' category. Although we could have different language environments for different languages in the category, so far nobody seriously needed it. I (Yoshiki) don't have good knowledge in these language, so when Pavel Krivanek volunteered to implement the detail, it was a good test to see how flexible my m17n framework was. There are a few glitches, but with several email conversations over a few days, we managed to make it work relatively painlessly. I thought this went well. There seem that some source of headache, as Windows doesn't exactly use Latin-2 encoded characters, but a little modified version called 'code page 1250'. Similar to Japanese support, the encode interpreters are swapped based on the type of platform it is running on. ! !Latin2Environment class methodsFor: 'language methods' stamp: 'yo 1/18/2005 08:32'! beCurrentNaturalLanguage ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 16:00'! clipboardInterpreterClass (#('Win32') includes: SmalltalkImage current platformName) ifTrue: [^CP1250ClipboardInterpreter ]. ^ ISO88592ClipboardInterpreter . ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:05'! defaultEncodingName | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^'utf-8' copy]. (#('Win32') includes: platformName) ifTrue: [^'cp-1250' copy]. (#('unix') includes: platformName) ifTrue: [^'iso8859-2' copy]. ^'mac-roman'! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:05'! fileNameConverterClass (#('Win32') includes: SmalltalkImage current platformName) ifTrue: [^CP1250TextConverter ]. ^ ISO88592TextConverter. ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 20:43'! inputInterpreterClass (#('Win32') includes: SmalltalkImage current platformName) ifTrue: [^CP1250InputInterpreter ]. ^ ISO88592InputInterpreter. ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/18/2005 15:53'! leadingChar ^ 14. ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 1/19/2005 09:16'! supportedLanguages "Return the languages that this class supports. Any translations for those languages will use this class as their environment." ^#('cs' 'hu' 'ro' 'hr' 'sk' 'sl') "Sorbian languages don't have two char code?" ! ! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'pk 1/19/2005 15:04'! systemConverterClass (#('Win32') includes: SmalltalkImage current platformName) ifTrue: [^CP1250TextConverter ]. ^ ISO88592TextConverter. ! ! !Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'! flapTabTextFor: aString ^ aString. ! ! !Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'! flapTabTextFor: aString in: aFlapTab ^ aString. ! ! !Latin2Environment class methodsFor: 'rendering support' stamp: 'yo 1/18/2005 08:32'! isBreakableAt: index in: text | char | char _ text at: index. char = Character space ifTrue: [^ true]. char = Character cr ifTrue: [^ true]. ^ false. ! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! flags ^flags ifNil: [ 0 ]! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! hSpaceFill ^self flags anyMask: 1! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! hSpaceFill: aBool flags _ aBool ifTrue:[self flags bitOr: 1] ifFalse:[self flags bitClear: 1]. ! ! !LayoutCell methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:09'! size | n cell | n := 0. cell := self. [cell isNil] whileFalse: [n := n + 1. cell := cell nextCell]. ^n! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! vSpaceFill ^self flags anyMask: 2! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! vSpaceFill: aBool flags _ aBool ifTrue:[self flags bitOr: 2] ifFalse:[self flags bitClear: 2]. ! ! !LayoutFrame methodsFor: 'layout' stamp: 'ar 2/5/2002 20:05'! minExtentFrom: minExtent "Return the minimal extent the given bounds can be represented in" | widthFraction heightFraction width height | widthFraction _ 1.0. leftFraction ifNotNil:[widthFraction _ widthFraction + leftFraction]. rightFraction ifNotNil:[widthFraction _ widthFraction + rightFraction]. heightFraction _ 1.0. topFraction ifNotNil:[heightFraction _ heightFraction + topFraction]. bottomFraction ifNotNil:[heightFraction _ heightFraction + bottomFraction]. width _ minExtent x * widthFraction. height _ minExtent y * heightFraction. leftOffset ifNotNil:[width _ width + leftOffset]. rightOffset ifNotNil:[width _ width + rightOffset]. topOffset ifNotNil:[height _ height + topOffset]. bottomOffset ifNotNil:[height _ height + bottomOffset]. ^width truncated @ height truncated! ! !LayoutFrame class methodsFor: 'as yet unclassified' stamp: 'ar 2/5/2002 00:07'! fractions: fractionsOrNil ^self fractions: fractionsOrNil offsets: nil! ! !LayoutFrame class methodsFor: 'as yet unclassified' stamp: 'ar 2/5/2002 20:06'! offsets: offsetsOrNil ^self fractions: nil offsets: offsetsOrNil! ! !LazyListMorph methodsFor: 'initialization' stamp: 'nk 10/14/2003 15:24'! initialize super initialize. self color: Color black. font := Preferences standardListFont. listItems := #(). selectedRow := nil. selectedRows := PluggableSet integerSet. self adjustHeight.! ! !LazyListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:12'! listSource: aListSource "set the source of list items -- typically a PluggableListMorph" listSource := aListSource. self listChanged! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/5/2000 18:21'! drawBoundsForRow: row "calculate the bounds that row should be drawn at. This might be outside our bounds!!" | topLeft drawBounds | topLeft := self topLeft x @ (self topLeft y + ((row - 1) * (font height))). drawBounds := topLeft extent: self width @ font height. ^drawBounds! ! !LazyListMorph methodsFor: 'list management' stamp: 'sps 3/9/2004 17:06'! listChanged "set newList to be the list of strings to display" listItems := Array new: self getListSize withAll: nil. selectedRow := nil. selectedRows := PluggableSet integerSet. self adjustHeight. self adjustWidth. self changed. ! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 10/20/2001 00:09'! rowAtLocation: aPoint "return the number of the row at aPoint" | y | y := aPoint y. y < self top ifTrue: [ ^ 1 ]. ^((y - self top // (font height)) + 1) min: listItems size max: 0! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/13/2000 17:34'! selectRow: index "select the index-th row" selectedRows add: index. self changed.! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/7/2000 10:38'! selectedRow "return the currently selected row, or nil if none is selected" ^selectedRow! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/5/2000 17:56'! selectedRow: index "select the index-th row. if nil, remove the current selection" selectedRow := index. self changed.! ! !LazyListMorph methodsFor: 'list management' stamp: 'ls 7/13/2000 17:35'! unselectRow: index "unselect the index-th row" selectedRows remove: index ifAbsent: []. self changed.! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/15/2001 22:13'! adjustHeight "private. Adjust our height to match the length of the underlying list" self height: (listItems size max: 1) * font height ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'sps 3/9/2004 17:06'! adjustWidth "private. Adjust our height to match the length of the underlying list" self width: ((listSource width max: self hUnadjustedScrollRange) + 20). ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! bottomVisibleRowForCanvas: aCanvas "return the bottom visible row in aCanvas's clip rectangle" ^self rowAtLocation: aCanvas clipRect bottomLeft. ! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 10/11/2003 13:12'! colorForRow: row ^(selectedRow notNil and: [ row = selectedRow]) ifTrue: [ Color red ] ifFalse: [ self color ].! ! !LazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:17'! display: item atRow: row on: canvas "display the given item at row row" | drawBounds | drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds. item isText ifTrue: [ canvas drawString: item in: drawBounds font: (font emphasized: (item emphasisAt: 1)) color: (self colorForRow: row) ] ifFalse: [ canvas drawString: item in: drawBounds font: font color: (self colorForRow: row) ].! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/10/2001 12:31'! drawBackgroundForMulti: row on: aCanvas | selectionDrawBounds | "shade the background darker, if this row is selected" selectionDrawBounds := self drawBoundsForRow: row. selectionDrawBounds := selectionDrawBounds intersect: self bounds. aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/22/2001 23:59'! drawBackgroundForPotentialDrop: row on: aCanvas | selectionDrawBounds | "shade the background darker, if this row is a potential drop target" selectionDrawBounds := self drawBoundsForRow: row. selectionDrawBounds := selectionDrawBounds intersect: self bounds. aCanvas fillRectangle: selectionDrawBounds color: self color muchLighter darker! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 12/6/2001 21:43'! drawOn: aCanvas | | listItems size = 0 ifTrue: [ ^self ]. self drawSelectionOn: aCanvas. (self topVisibleRowForCanvas: aCanvas) to: (self bottomVisibleRowForCanvas: aCanvas) do: [ :row | (listSource itemSelectedAmongMultiple: row) ifTrue: [ self drawBackgroundForMulti: row on: aCanvas. ]. self display: (self item: row) atRow: row on: aCanvas. ]. listSource potentialDropRow > 0 ifTrue: [ self highlightPotentialDropRow: listSource potentialDropRow on: aCanvas ].! ! !LazyListMorph methodsFor: 'drawing' stamp: 'nk 10/14/2003 15:18'! drawSelectionOn: aCanvas | selectionDrawBounds | selectedRow ifNil: [ ^self ]. selectedRow = 0 ifTrue: [ ^self ]. selectionDrawBounds := self drawBoundsForRow: selectedRow. selectionDrawBounds := selectionDrawBounds intersect: self bounds. aCanvas fillRectangle: selectionDrawBounds color: (Color lightGray alpha: 0.3)! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:37'! font "return the font used for drawing. The response is never nil" ^font! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:04'! font: newFont font := (newFont ifNil: [ TextStyle default defaultFont ]). self adjustHeight. self changed.! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 6/23/2001 00:13'! highlightPotentialDropRow: row on: aCanvas | drawBounds | drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds. aCanvas frameRectangle: drawBounds color: Color blue! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:57'! topVisibleRowForCanvas: aCanvas "return the top visible row in aCanvas's clip rectangle" ^self rowAtLocation: aCanvas clipRect topLeft. ! ! !LazyListMorph methodsFor: 'list access' stamp: 'ls 8/19/2001 14:07'! getListItem: index "grab a list item directly from the model" ^listSource getListItem: index! ! !LazyListMorph methodsFor: 'list access' stamp: 'ls 5/15/2001 22:11'! getListSize "return the number of items in the list" listSource ifNil: [ ^0 ]. ^listSource getListSize! ! !LazyListMorph methodsFor: 'list access' stamp: 'ls 10/21/2001 20:57'! item: index "return the index-th item, using the 'listItems' cache" (index between: 1 and: listItems size) ifFalse: [ "there should have been an update, but there wasn't!!" ^self getListItem: index]. (listItems at: index) ifNil: [ listItems at: index put: (self getListItem: index). ]. ^listItems at: index! ! !LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:18'! hUnadjustedScrollRange "Ok, this is a bit messed up. We need to return the width of the widest item in the list. If we grab every item in the list, it defeats the purpose of LazyListMorph. If we don't, then we don't know the size. This is a compromise -- if the list is less then 30 items, we grab them all. If not, we grab currently visible ones, until we've checked itemsToCheck of them, then take the max width out of that 'sampling', then double it. If you know a better way, please chime in." | maxW count itemsToCheck item | itemsToCheck _ 30. maxW _ 0. count _ 0. listItems do: [ :each | each ifNotNil: [maxW _ maxW max: (self widthToDisplayItem: each contents)]]. (count < itemsToCheck) ifTrue: [1 to: listItems size do: [:i | (listItems at: i) ifNil: [item _ self item: i. maxW _ maxW max: (self widthToDisplayItem: item contents). ((count _ count + 1) > itemsToCheck) ifTrue:[ ^maxW * 2]]]]. ^maxW ! ! !LazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:17'! widthToDisplayItem: item ^self font widthOfStringOrText: item ! ! !LazyListMorph commentStamp: 'ls 10/11/2003 13:10' prior: 0! The morph that displays the list in a PluggableListMorph. It is "lazy" because it will only request the list items that it actually needs to display.! !LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:51'! key: object key _ object. ! ! !LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:51'! key: object code: byte self key: object. self code: byte! ! !LeafNode methodsFor: 'initialize-release' stamp: 'ab 7/13/2004 13:52'! name: ignored key: object code: byte self key: object. self code: byte! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:39'! code ^ code! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:41'! code: aValue code := aValue! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:42'! emitLong: mode on: aStream "Emit extended variable access." | type index | self code < 256 ifTrue: [self code < 16 ifTrue: [type _ 0. index _ self code] ifFalse: [self code < 32 ifTrue: [type _ 1. index _ self code - 16] ifFalse: [self code < 96 ifTrue: [type _ self code // 32 + 1. index _ self code \\ 32] ifFalse: [self error: 'Sends should be handled in SelectorNode']]]] ifFalse: [index _ self code \\ 256. type _ self code // 256 - 1]. index <= 63 ifTrue: [aStream nextPut: mode. ^ aStream nextPut: type * 64 + index]. "Compile for Double-exetended Do-anything instruction..." mode = LoadLong ifTrue: [aStream nextPut: DblExtDoAll. aStream nextPut: (#(64 0 96 128) at: type+1). "Cant be temp (type=1)" ^ aStream nextPut: index]. mode = Store ifTrue: [aStream nextPut: DblExtDoAll. aStream nextPut: (#(160 0 0 224) at: type+1). "Cant be temp or const (type=1 or 2)" ^ aStream nextPut: index]. mode = StorePop ifTrue: [aStream nextPut: DblExtDoAll. aStream nextPut: (#(192 0 0 0) at: type+1). "Can only be inst" ^ aStream nextPut: index]. ! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'! reserve: encoder "If this is a yet unused literal of type -code, reserve it." self code < 0 ifTrue: [self code: (self code: (encoder litIndex: self key) type: 0 - self code)]! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:40'! sizeForValue: encoder self reserve: encoder. self code < 256 ifTrue: [^ 1]. (self code \\ 256) <= 63 ifTrue: [^ 2]. ^ 3! ! !LeafNode methodsFor: 'copying' stamp: 'ab 7/13/2004 13:53'! veryDeepFixupWith: deepCopier "If fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. self key: (deepCopier references at: self key ifAbsent: [self key]). ! ! !LeafNode methodsFor: 'copying' stamp: 'ab 7/6/2004 17:42'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "key _ key. Weakly copied" self code: (self code veryDeepCopyWith: deepCopier). ! ! !LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:02'! char ^ char ! ! !LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 6/12/2000 15:13'! char: aCharacter char _ aCharacter digitValue. char >= 0 & (char <= 35) ifFalse: [char _ 36]! ! !LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 19:03'! highlighted ^ highlighted! ! !LedCharacterMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 19:03'! highlighted: aBoolean highlighted _ aBoolean. self changed.! ! !LedCharacterMorph methodsFor: 'drawing' stamp: 'kfr 6/3/2000 21:29'! drawOn: aCanvas | foregroundColor backgroundColor thickness hThickness vThickness hOffset vOffset bOrigin i | i _ 0. foregroundColor _ highlighted ifTrue: [Color white] ifFalse: [color]. backgroundColor _ color darker darker darker. hThickness _ self height * 0.1. vThickness _ self width * 0.1. thickness _ hThickness min: vThickness. vOffset _ hThickness - thickness // 2 max: 0. hOffset _ vThickness - thickness // 2 max: 0. aCanvas fillRectangle: self bounds color: backgroundColor. CHSegmentOrigins with: (CHSegments at: char + 1) do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (0 @ vOffset) + (o * self extent)) rounded extent: (self width * 0.6 @ thickness) rounded) color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])]. CVSegmentOrigins with: (CVSegments at: char + 1) do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (hOffset @ 0) + (o * self extent)) rounded extent: (thickness @ (self height * 0.25)) rounded) color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])]. TSegments with: (DSegments at: char + 1) do: [:tOrigin :isLit | i _ i + 1. bOrigin _ BSegments at: i. aCanvas line: self position x - hOffset + (self width * tOrigin x) @ (self position y - vOffset + (self height * tOrigin y)) to: self position x + hOffset + (self width * bOrigin x) @ (self position y + vOffset + (self height * bOrigin y)) width: thickness + 1 // 1.25 color: (isLit ifTrue: [foregroundColor] ifFalse: [Color transparent])]! ! !LedCharacterMorph methodsFor: 'drawing' stamp: 'kfr 5/26/2000 19:03'! drawOnFills: aRectangle ^ true! ! !LedCharacterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:27'! defaultColor "answer the default color/fill style for the receiver" ^ Color green! ! !LedCharacterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:55'! initialize "initialize the state of the receiver" super initialize. "" highlighted _ false. char _ 0! ! !LedCharacterMorph commentStamp: '<historical>' prior: 0! char 36 is SPACE! !LedCharacterMorph class methodsFor: 'class initialization' stamp: 'kfr 6/3/2000 21:32'! initialize CHSegmentOrigins _ {0.2@0.1. 0.2@0.45. 0.2@0.8}. CVSegmentOrigins _ {0.1@0.2. 0.1@0.55. 0.8@0.2. 0.8@0.55}. TSegments _ { 0.25@0.25. 0.45@0.25. 0.55@0.25. 0.75@0.25. 0.25@0.6. 0.45@0.6. 0.55@0.6. 0.75@0.6. }. BSegments _ { 0.45@0.4. 0.25@0.4. 0.75@0.4. 0.55@0.4. 0.45@0.76. 0.25@0.76. 0.75@0.76. 0.55@0.76. }. DSegments _ { {false. false. false. false. false. false. false. false. }."0" {false. false. false. false. false. false. false. false. }."1" {false. false. false. false. false. false. false. false. }."2" {false. false. false. false. false. false. false. false. }."3" {false. false. false. false. false. false. false. false. }."4" {false. false. false. false. false. false. false. false. }."5" {false. false. false. false. false. false. false. false. }."6" {false. false. false. false. false. false. false. false. }."7" {false. false. false. false. false. false. false. false. }."8" {false. false. false. false. false. false. false. false. }."9" {false. false. false. false. false. false. false. false. }."A" {false. false. false. false. false. false. false. false. }."B" {false. false. false. false. false. false. false. false. }."C" {false. false. false. false. false. false. false. false. }."D" {false. false. false. false. false. false. false. false. }."E" {false. false. false. false. false. false. false. false. }."F" {false. false. false. false. false. false. false. false. }."G" {false. false. false. false. false. false. false. false. }."H" {false. false. false. false. false. false. false. false. }."I" {false. false. false. false. false. false. false. false. }."J" {false. false. false. true. false. false. false. false. }."K" {false. false. false. false. false. false. false. false. }."L" {true. false. false. true. false. false. false. false. }."M" {true. false. false. false. false. false. true. false. }."N" {false. true. true. false. true. false. false. true. }."O" {false. false. false. false. false. false. false. false. }."P" {false. false. false. false. false. false. true. false. }."Q" {false. false. false. false. false. false. true. false. }."R" {false. false. false. false. false. false. false. false. }."S" {false. false. false. false. false. false. false. false. }."T" {false. false. false. false. false. false. false. false. }."U" {false. false. false. false. true. false. false. true. }."V" {false. false. false. false. false. true. true. false. }."W" {true. false. false. true. false. true. true. false. }."X" {false. false. false. false. false. false. false. false. }."Y" {false. false. false. true. false. true. false. false. }."Z" {false. false. false. false. false. false. false. false. }}."SPACE" CHSegments _ { {true. false. true}."0" {false. false. false}."1" {true. true. true}."2" {true. true. true}."3" {false. true. false}."4" {true. true. true}."5" {true. true. true}."6" {true. false. false}."7" {true. true. true}."8" {true. true. true}."9" {true. true. false}."A" {true. true. true}."B" {true. false. true}."C" {true. false. true}."D" {true. true. true}."E" {true. true. false}."F" {true. true. true}."G" {false. true. false}."H" {false. false. false}."I" {false. false. true}."J" {false. true. false}."K" {false. false. true}."L" {false. false. false}."M" {false. false. false}."N" {false. false. false}."O" {true. true. false}."P" {true. false. true}."Q" {true. true. false}."R" {true. true. true}."S" {false. true. true}."t" {false. false. true}."U" {false. false. false}."V" {false. false. false}."W" {false. false. false}."X" {false. true. true}."Y" {true. false. true}."Z" {false. false. false.}}."SPACE" CVSegments _ { {true. true. true. true}."0" {false. false. true. true}."1" {false. true. true. false}."2" {false. false. true. true}."3" {true. false. true. true}."4" {true. false. false. true}."5" {true. true. false. true}."6" {false. false. true. true}."7" {true. true. true. true}."8" {true. false. true. true}."9" {true. true. true. true}."A" {true. true. true. true}."B" {true. true. false. false}."C" {true. true. true. true}."D" {true. true. false. false}."E" {true. true. false. false}."F" {true. true. false. true}."G" {true. true. true. true}."H" {true. true. false. false}."I" {false. true. true. true}."J" {true. true. false. true}."K" {true. true. false. false}."L" {true. true. true. true}."N" {true. true. true. true}."N" {false. false. false. false}."O" {true. true. true. false}."P" {true. true. true. true}."q" {true. true. true. false}."R" {true. false. false. true}."S" {true. true. false. false}."t" {true. true. true. true}."U" {true. false. true. false}."V" {true. true. true. true}."w" {false. false. false. false}."x" {true. false. true. true}."y" {false. false. false. false}."z" {false. false. false. false}}."SPACE"! ! !LedCharacterMorph class methodsFor: 'new-morph participation' stamp: 'kfr 5/26/2000 19:03'! includeInNewMorphMenu ^false! ! !LedDigitMorph methodsFor: 'drawing' stamp: 'dew 1/16/2002 20:44'! drawOn: aCanvas | foregroundColor backgroundColor thickness hThickness vThickness hOffset vOffset | foregroundColor _ highlighted ifTrue: [Color white] ifFalse: [color]. backgroundColor _ color muchDarker. hThickness _ self height * 0.1. vThickness _ self width * 0.1. thickness _ hThickness min: vThickness. vOffset _ ((hThickness - thickness) // 2) max: 0. hOffset _ ((vThickness - thickness) // 2) max: 0. aCanvas fillRectangle: self bounds color: backgroundColor. "added to show the minus sign" (digit asString = '-') ifTrue: [digit _ 10]. HSegmentOrigins with: (HSegments at: digit+1) do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (0@vOffset) + (o * self extent)) rounded extent: ((self width * 0.6) @ thickness) rounded) color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])]. VSegmentOrigins with: (VSegments at: digit+1) do: [:o :isLit | aCanvas fillRectangle: (Rectangle origin: (self position + (hOffset@0) + (o * self extent)) rounded extent: (thickness @ (self height * 0.25)) rounded) color: (isLit ifTrue: [foregroundColor] ifFalse: [backgroundColor])]. ! ! !LedDigitMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color green! ! !LedDigitMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:34'! initialize "initialize the state of the receiver" super initialize. "" highlighted _ false. digit _ 0 ! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:16'! chars ^ chars! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 6/3/2000 21:27'! chars: aNumber chars _ aNumber. self removeAllMorphs. 1 to: chars do: [:i | self addMorph: (LedCharacterMorph new color: color)]. self layoutChanged. self changed! ! !LedMorph methodsFor: 'accessing' stamp: 'dgd 2/14/2003 22:46'! color: aColor "set the receiver's color and the submorphs color" super color: aColor. self submorphsDo: [:m | m color: aColor]! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 6/1/2000 18:50'! scrollLoop ^ scrollLoop! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 6/1/2000 18:50'! scrollLoop: aBoolean scrollLoop _ aBoolean.! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 5/26/2000 20:25'! string ^ string! ! !LedMorph methodsFor: 'accessing' stamp: 'kfr 6/12/2000 15:29'! string: aString string _ aString. chars = 0 ifTrue: [chars _ string size. self chars: chars]. self stringToLed! ! !LedMorph methodsFor: 'accessing' stamp: 'tk 4/19/2001 16:55'! stringToLed | i k actualString | i _ scroller ifNil: [1]. k _ 1. actualString _ String new: chars. actualString do: [:m | i > string size ifFalse: [actualString at: k put: (string at: i) asUppercase asCharacter]. i _ i + 1. k _ k + 1]. i _ 1. submorphs do: [:m | m char: (actualString at: i). i _ i + 1]. self changed! ! !LedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36'! defaultColor "answer the default color/fill style for the receiver" ^ Color green! ! !LedMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36'! initialize "initialize the state of the receiver" super initialize. "" flashing _ false. flash _ false. self scrollInit. self digits: 2. self value: 0! ! !LedMorph methodsFor: 'initialization' stamp: 'di 3/8/2001 23:44'! scrollInit chars _ 0. scroller _ 1. string _ ''. scrollLoop _ false. ! ! !LedMorph methodsFor: 'stepping and presenter' stamp: 'tk 4/19/2001 17:02'! step (flash or: [flashing]) ifTrue: [flashing _ flashing not. self highlighted: flashing]. scroller ifNil: [scroller _ 1]. chars ifNil: [^ self]. scroller + chars < (string size + 1) ifTrue: [scroller _ scroller + 1. self stringToLed] ifFalse: [scrollLoop ifTrue: [scroller _ 1]]! ! !LedMorph commentStamp: '<historical>' prior: 0! I am a collection of LED digits that can display a decimal value. The display can be set to flash by sending flash: true. LedMorph can now display characters: LedMorph new string:'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'; openInWorld Lowercase letters will be converted to Uppercase. Carachters not in the examle above will be shown as SPACE which is char 36 in LedCharacterMorph. LedMorph new chars: 10; string:' I must get a life';flash:true;scrollLoop:true; openInWorld The number of letters is set by chars. If chars is not specified it will be set to the string size. When the string size is bigger than chars the string will scroll across the led. WOW!! scrollLoop let's you set the scrolling to start over once its finished. Enjoy. ! !LedTimerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:36'! initialize "initialize the state of the receiver" super initialize. "" counting _ false. startSeconds _ Time totalSeconds! ! !Lexicon methodsFor: 'initialization' stamp: 'sw 12/18/2000 16:12'! initListFrom: selectorCollection highlighting: aClass "Make up the messageList with items from aClass in boldface. Provide a final filtering in that only selectors whose implementations fall within my limitClass will be shown." | defClass item | messageList := OrderedCollection new. selectorCollection do: [:selector | defClass _ aClass whichClassIncludesSelector: selector. (defClass notNil and: [defClass includesBehavior: self limitClass]) ifTrue: [item _ selector, ' (' , defClass name , ')'. item _ item asText. defClass == aClass ifTrue: [item allBold]. "(self isThereAnOverrideOf: selector) ifTrue: [item addAttribute: TextEmphasis struckOut]." "The above has a germ of a good idea but could be very slow" messageList add: item]]! ! !Lexicon methodsFor: 'initialization' stamp: 'hmm 3/3/2004 22:17'! openOnClass: aTargetClass inWorld: aWorld showingSelector: aSelector "Create and open a SystemWindow to house the receiver, showing the categories pane. The target-object parameter is optional -- if nil, the browser will be associated with the class as a whole but not with any particular instance of it." | window aListMorph catListFraction | currentVocabulary ifNil: [currentVocabulary _ Vocabulary fullVocabulary]. targetClass _ aTargetClass. self initialLimitClass. window _ self windowWithLabel: self startingWindowTitle. catListFraction _ 0.20. window addMorph: self newCategoryPane frame: (0 @ 0 corner: 0.5 @ catListFraction). aListMorph _ PluggableListMorph new. aListMorph setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForLexiconString. aListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph setNameTo: 'messageList'. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0.5 @ 0 corner: 1 @ catListFraction). "side by side" self reformulateCategoryList. "needs to do this here because otherwise the following will break due to change 5738" self addLowerPanesTo: window at: (0 @ catListFraction corner: 1@1) with: nil. window changeAllBorderColorsFrom: Color black to: (self defaultBackgroundColor mixed: 0.5 with: Color black). window color: self defaultBackgroundColor. window openInWorld: aWorld. aSelector ifNotNil: [self selectSelectorItsNaturalCategory: aSelector] ifNil: [self categoryListIndex: 1]. #(navigateToPreviousMethod navigateToNextMethod removeFromSelectorsVisited) do: [:sel | (self buttonWithSelector: sel) ifNotNilDo: [:aButton | aButton borderWidth: 0]]. self adjustWindowTitle! ! !Lexicon methodsFor: 'initialization' stamp: 'sw 1/30/2001 22:24'! openWithSearchPaneOn: aTargetClass inWorld: aWorld "Create and open a SystemWindow to house the receiver, search-pane variant. Only sender is currently unsent; a disused branch but still for the moment retained" | window aListMorph aTextMorph baseline typeInPane | targetClass _ aTargetClass. window _ self windowWithLabel: 'Vocabulary of ', aTargetClass nameForViewer. window addMorph: self newSearchPane frame: (0@0 extent: 1@0.05). aListMorph _ PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0.05 extent: 1@0.25). self wantsAnnotationPane ifFalse: [baseline _ 0.25] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.25 corner: 1@0.35). baseline _ 0.35]. self wantsOptionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. typeInPane _ PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. typeInPane retractable: false. window addMorph: typeInPane frame: (0 @ baseline corner: 1 @ 1). window setUpdatablePanesFrom: #(messageList). window openInWorld: aWorld. self flag: #deferred. "self initListFrom: aTargetClass allCategoriesInProtocol asSortedCollection highlighting: aTargetClass" "(Lexicon new useProtocol: Protocol fullProtocol) openWithSearchPaneOn: TileMorph inWorld: self currentWorld" ! ! !Lexicon methodsFor: 'initialization' stamp: 'sw 1/24/2001 21:25'! wantsAnnotationPane "This kind of browser always wants annotation panes, so answer true" ^ true! ! !Lexicon methodsFor: 'initialization' stamp: 'sw 12/18/2000 23:19'! windowWithLabel: aLabel "Answer a SystemWindow associated with the receiver, with appropriate border characteristics" | window | (window _ SystemWindow labelled: aLabel) model: self. "window borderWidth: 1; borderColor: self defaultBackgroundColor darker." ^ window ! ! !Lexicon methodsFor: 'basic operation' stamp: 'sw 3/20/2001 16:06'! annotation "Provide a line of annotation material for a middle pane." | aCategoryName | self selectedMessageName ifNotNil: [^ super annotation]. (aCategoryName _ self selectedCategoryName) ifNil: [^ self hasSearchPane ifTrue: ['type a message name or fragment in the top pane and hit RETURN or ENTER'] ifFalse: ['' "currentVocabulary documentation"]]. (aCategoryName = self class queryCategoryName) ifTrue: [^ self queryCharacterization]. #( (allCategoryName 'Shows all methods, whatever other category they belong to') (viewedCategoryName 'Methods visited recently. Use "-" button to remove a method from this category.') (queryCategoryName 'Query results')) do: [:pair | (self categoryWithNameSpecifiedBy: pair first) = aCategoryName ifTrue: [^ pair second]]. ^ currentVocabulary categoryCommentFor: aCategoryName! ! !Lexicon methodsFor: 'basic operation' stamp: 'nb 6/17/2003 12:25'! displaySelector: aSelector "Set aSelector to be the one whose source shows in the browser. If there is a category list, make it highlight a suitable category" | detectedItem messageIndex | self chooseCategory: (self categoryDefiningSelector: aSelector). detectedItem _ messageList detect: [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ Beeper beep]. messageIndex _ messageList indexOf: detectedItem. self messageListIndex: messageIndex! ! !Lexicon methodsFor: 'basic operation' stamp: 'nk 2/14/2004 15:10'! messageListIndex: anIndex "Set the message list index as indicated, and update the history list if appropriate" | newSelector current | current _ self selectedMessageName. super messageListIndex: anIndex. anIndex = 0 ifTrue: [ self editSelection: #newMessage. self contentsChanged]. (newSelector _ self selectedMessageName) ifNotNil: [self updateSelectorsVisitedfrom: current to: newSelector]! ! !Lexicon methodsFor: 'category list' stamp: 'sw 3/7/2001 12:19'! categoriesPane "If there is a pane defined by #categoryList in my containing window, answer it, else answer nil" ^ self listPaneWithSelector: #categoryList! ! !Lexicon methodsFor: 'category list' stamp: 'sw 3/20/2001 12:13'! categoryDefiningSelector: aSelector "Answer a category in which aSelector occurs" | categoryNames | categoryNames _ categoryList copyWithoutAll: #('-- all --'). ^ currentVocabulary categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: self targetObject ofClass: targetClass! ! !Lexicon methodsFor: 'category list' stamp: 'sw 5/25/2001 01:34'! categoryList "Answer the category list for the protcol, creating it if necessary, and prepending the -- all -- category, and appending the other special categories for search results, etc." | specialCategoryNames | categoryList ifNil: [specialCategoryNames _ #(queryCategoryName viewedCategoryName "searchCategoryName sendersCategoryName changedCategoryName activeCategoryName") collect: [:sym | self class perform: sym]. categoryList _ (currentVocabulary categoryListForInstance: self targetObject ofClass: targetClass limitClass: limitClass), specialCategoryNames, (Array with: self class allCategoryName)]. ^ categoryList! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 19:37'! categoryListIndex "Answer the index of the currently-selected item in in the category list" ^ categoryListIndex ifNil: [categoryListIndex _ 1]! ! !Lexicon methodsFor: 'category list' stamp: 'sw 3/20/2001 20:19'! categoryListIndex: anIndex "Set the category list index as indicated" | categoryName aList found existingSelector | existingSelector _ self selectedMessageName. categoryListIndex _ anIndex. anIndex > 0 ifTrue: [categoryName _ categoryList at: anIndex] ifFalse: [contents _ nil]. self changed: #categoryListIndex. found _ false. #( (viewedCategoryName selectorsVisited) (queryCategoryName selectorsRetrieved)) do: [:pair | categoryName = (self class perform: pair first) ifTrue: [aList _ self perform: pair second. found _ true]]. found ifFalse: [aList _ currentVocabulary allMethodsInCategory: categoryName forInstance: self targetObject ofClass: targetClass]. categoryName = self class queryCategoryName ifFalse: [autoSelectString _ nil]. self initListFrom: aList highlighting: targetClass. messageListIndex _ 0. self changed: #messageList. contents _ nil. self contentsChanged. self selectWithinCurrentCategoryIfPossible: existingSelector. self adjustWindowTitle! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 11:50'! categoryListKey: aChar from: aView "The user hit a command-key while in the category-list. Do something" (aChar == $f and: [self hasSearchPane not]) ifTrue: [^ self obtainNewSearchString].! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 11:50'! categoryListMenu: aMenu shifted: aBoolean "Answer the menu for the category list" ^ aMenu labels: 'find...(f)' lines: #() selections: #(obtainNewSearchString)! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/1/2000 22:13'! categoryListMenuTitle "Answer the menu title for the category list menu" ^ 'categories'! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/13/2000 10:38'! categoryWithNameSpecifiedBy: aSelector "Answer the category name obtained by sending aSelector to my class. This provides a way to avoid hard-coding the wording of conventions such as '-- all --'" ^ self class perform: aSelector! ! !Lexicon methodsFor: 'category list' stamp: 'nb 6/17/2003 12:25'! chooseCategory: aCategory "Choose the category of the given name, if there is one" self categoryListIndex: (categoryList indexOf: aCategory ifAbsent: [^ Beeper beep])! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/28/2000 13:46'! newCategoryPane "Formulate a category pane for insertion into the receiver's pane list" | aListMorph | aListMorph _ PluggableListMorph on: self list: #categoryList selected: #categoryListIndex changeSelected: #categoryListIndex: menu: #categoryListMenu:shifted: keystroke: #categoryListKey:from:. aListMorph setNameTo: 'categoryList'. aListMorph menuTitleSelector: #categoryListMenuTitle. ^ aListMorph! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/11/2000 14:47'! reformulateCategoryList "Reformulate the category list" categoryList _ nil. self categoryListIndex: 0. self changed: #categoryList. self contentsChanged! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/11/2000 14:52'! selectWithinCurrentCategoryIfPossible: aSelector "If the receiver's message list contains aSelector, navigate right to it without changing categories" | detectedItem messageIndex | aSelector ifNil: [^ self]. detectedItem _ messageList detect: [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self]. messageIndex _ messageList indexOf: detectedItem. self messageListIndex: messageIndex ! ! !Lexicon methodsFor: 'category list' stamp: 'sw 12/12/2000 19:38'! selectedCategoryName "Answer the selected category name" ^ categoryList ifNotNil: [categoryList at: categoryListIndex ifAbsent: [nil]]! ! !Lexicon methodsFor: 'category list' stamp: 'sd 4/29/2003 12:15'! selectorsReferringToClassVar "Return a list of methods that refer to given class var that are in the protocol of this object" | aList aClass nonMeta poolAssoc | nonMeta _ targetClass theNonMetaClass. aClass _ nonMeta classThatDefinesClassVariable: currentQueryParameter. aList _ OrderedCollection new. poolAssoc _ aClass classPool associationAt: currentQueryParameter asSymbol. (self systemNavigation allCallsOn: poolAssoc) do: [:elem | (nonMeta isKindOf: elem actualClass) ifTrue: [aList add: elem methodSymbol]]. ^ aList! ! !Lexicon methodsFor: 'category list' stamp: 'nb 6/17/2003 12:25'! showCategoriesPane "Show the categories pane instead of the search pane" | aPane | (aPane _ self searchPane) ifNil: [^ Beeper beep]. self containingWindow replacePane: aPane with: self newCategoryPane. categoryList _ nil. self changed: #categoryList. self changed: #messageList! ! !Lexicon methodsFor: 'control buttons' stamp: 'sw 7/23/2002 12:56'! customButtonRow "Answer a custom row of widgets, which pertain primarily to within-tool navigation" | aRow aButton aLabel | aRow _ AlignmentMorph newRow. aRow setNameTo: 'navigation controls'. aRow beSticky. aRow hResizing: #spaceFill. aRow wrapCentering: #center; cellPositioning: #leftCenter. aRow clipSubmorphs: true. aRow cellInset: 3. self customButtonSpecs do: [:triplet | aButton _ PluggableButtonMorph on: self getState: nil action: triplet second. aButton useRoundedCorners; hResizing: #spaceFill; vResizing: #spaceFill; onColor: Color transparent offColor: Color transparent. aLabel _ Preferences abbreviatedBrowserButtons ifTrue: [self abbreviatedWordingFor: triplet second] ifFalse: [nil]. aButton label: (aLabel ifNil: [triplet first asString]) " font: (StrikeFont familyName: 'Atlanta' size: 9)". triplet size > 2 ifTrue: [aButton setBalloonText: triplet third]. triplet size > 3 ifTrue: [aButton triggerOnMouseDown: triplet fourth]. aRow addMorphBack: aButton]. aRow addMorphBack: self homeCategoryButton. aRow addMorphFront: (Morph new extent: (4@10)) beTransparent. aRow addMorphFront: self mostGenericButton. aRow addMorphFront: self menuButton. ^ aRow! ! !Lexicon methodsFor: 'control buttons' stamp: 'sw 7/23/2002 12:51'! customButtonSpecs "Answer a triplet defining buttons, in the format: button label selector to send help message" | aa | aa _ contentsSymbol == #tiles ifTrue: [{ "Consult Ted Kaehler regarding this bit" {'tiles'. #tilesMenu. 'tiles for assignment and constants'. true}. {'vars'. #varTilesMenu. 'tiles for instance variables and a new temporary'. true} }] ifFalse: [#()]. "true in 4th place means act on mouseDown" ^ aa, #( ('follow' seeAlso 'view a method I implement that is called by this method') ('find' obtainNewSearchString 'find methods by name search') ('sent...' setSendersSearch 'view the methods I implement that send a given message') ('<' navigateToPreviousMethod 'view the previous active method') ('>' navigateToNextMethod 'view the next active method') ('-' removeFromSelectorsVisited 'remove this method from my active list'))! ! !Lexicon methodsFor: 'control buttons' stamp: 'sw 10/8/2001 14:33'! homeCategoryButton "Answer a button that brings up a menu. Useful when adding new features, but at present is between uses" ^ IconicButton new target: self; borderWidth: 0; labelGraphic: (ScriptingSystem formAtKey: #Cat); color: Color transparent; actWhen: #buttonUp; actionSelector: #showHomeCategory; setBalloonText: 'show this method''s home category'; yourself! ! !Lexicon methodsFor: 'control buttons' stamp: 'sw 2/26/2002 12:06'! mostGenericButton "Answer a button that reports on, and allow the user to modify, the most generic class to show" | aButton | aButton _ UpdatingSimpleButtonMorph newWithLabel: 'All'. aButton setNameTo: 'limit class'. aButton target: self; wordingSelector: #limitClassString; actionSelector: #chooseLimitClass. aButton setBalloonText: 'Governs which classes'' methods should be shown. If this is the same as the viewed class, then only methods implemented in that class will be shown. If it is ProtoObject, then methods of all classes in the vocabulary will be shown.'. aButton actWhen: #buttonDown. aButton color: Color transparent. aButton borderColor: Color black. ^ aButton! ! !Lexicon methodsFor: 'control buttons' stamp: 'sw 3/20/2001 19:47'! searchToggleButton "Return a checkbox governing whether a search pane or a categories pane is used. No senders at the moment, but this feature might be useful someday." | outerButton aButton | outerButton _ AlignmentMorph newRow. outerButton wrapCentering: #center; cellPositioning: #leftCenter. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ UpdatingThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleSearch; getSelector: #hasSearchPane. outerButton addMorphBack: (StringMorph contents: 'search') lock. outerButton setBalloonText: 'If checked, then a search pane is used, if not, then a categories pane will be seen instead'. ^ outerButton ! ! !Lexicon methodsFor: 'history' stamp: 'sw 12/14/2000 14:35'! navigateToNextMethod "Navigate to the 'next' method in the current viewing sequence" | anIndex aSelector | self selectorsVisited size == 0 ifTrue: [^ self]. anIndex _ (aSelector _ self selectedMessageName) notNil ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]] ifFalse: [1]. self selectedCategoryName == self class viewedCategoryName ifTrue: [self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex + 1))] ifFalse: [self displaySelector: (selectorsVisited atWrap: (anIndex + 1))]! ! !Lexicon methodsFor: 'history' stamp: 'sw 12/14/2000 14:35'! navigateToPreviousMethod "Navigate to the 'previous' method in the current viewing sequence" | anIndex aSelector | self selectorsVisited size == 0 ifTrue: [^ self]. anIndex _ (aSelector _ self selectedMessageName) notNil ifTrue: [selectorsVisited indexOf: aSelector ifAbsent: [selectorsVisited size]] ifFalse: [selectorsVisited size]. self selectedCategoryName == self class viewedCategoryName ifTrue: [self selectWithinCurrentCategory: (selectorsVisited atWrap: (anIndex - 1))] ifFalse: [self displaySelector: (selectorsVisited atWrap: (anIndex - 1))]! ! !Lexicon methodsFor: 'history' stamp: 'sw 12/5/2000 16:27'! navigateToRecentMethod "Put up a menu of recent selectors visited and navigate to the one chosen" | visited aSelector | (visited _ self selectorsVisited) size > 1 ifTrue: [visited _ visited copyFrom: 1 to: (visited size min: 20). aSelector _ (SelectionMenu selections: visited) startUpWithCaption: 'Recent methods visited in this browser'. aSelector isEmptyOrNil ifFalse: [self displaySelector: aSelector]]! ! !Lexicon methodsFor: 'history' stamp: 'sw 3/19/2001 10:58'! removeFromSelectorsVisited "Remove the currently-selected method from the active set" | aSelector | (aSelector _ self selectedMessageName) ifNil: [^ self]. self removeFromSelectorsVisited: aSelector. self chooseCategory: self class viewedCategoryName! ! !Lexicon methodsFor: 'history' stamp: 'sw 3/19/2001 07:43'! removeFromSelectorsVisited: aSelector "remove aSelector from my history list" self selectorsVisited remove: aSelector ifAbsent: []! ! !Lexicon methodsFor: 'history' stamp: 'sw 12/5/2000 16:27'! selectorsVisited "Answer the list of selectors visited in this tool" ^ selectorsVisited ifNil: [selectorsVisited _ OrderedCollection new]! ! !Lexicon methodsFor: 'history' stamp: 'sw 12/11/2000 08:49'! updateSelectorsVisitedfrom: oldSelector to: newSelector "Update the list of selectors visited." newSelector == oldSelector ifTrue: [^ self]. self selectorsVisited remove: newSelector ifAbsent: []. (selectorsVisited includes: oldSelector) ifTrue: [selectorsVisited add: newSelector after: oldSelector] ifFalse: [selectorsVisited add: newSelector] ! ! !Lexicon methodsFor: 'limit class' stamp: 'sw 3/19/2001 06:41'! chooseLimitClass "Put up a menu allowing the user to choose the most generic class to show" | aMenu | aMenu _ MenuMorph new defaultTarget: self. targetClass withAllSuperclasses do: [:aClass | aClass == ProtoObject ifTrue: [aMenu addLine]. aMenu add: aClass name selector: #setLimitClass: argument: aClass. aClass == limitClass ifTrue: [aMenu lastItem color: Color red]. aClass == targetClass ifTrue: [aMenu addLine]]. aMenu addTitle: 'Show only methods implemented at or above...'. "heh heh -- somebody please find nice wording here!!" aMenu popUpInWorld: self currentWorld! ! !Lexicon methodsFor: 'limit class' stamp: 'cmm 3/26/2003 22:33'! initialLimitClass "Choose a plausible initial vlaue for the limit class, and answer it" | oneTooFar | limitClass _ targetClass. (#('ProtoObject' 'Object' 'Behavior' 'ClassDescription' 'Class' 'ProtoObject class' 'Object class') includes: targetClass name asString) ifTrue: [^ targetClass]. oneTooFar _ (targetClass isKindOf: Metaclass) ifTrue: ["use the fifth back from the superclass chain for Metaclasses, which is the immediate subclass of ProtoObject class. Print <ProtoObject class allSuperclasses> to count them yourself." targetClass allSuperclasses at: (targetClass allSuperclasses size - 5)] ifFalse: [targetClass allSuperclasses at: targetClass allSuperclasses size]. [limitClass superclass ~~ oneTooFar] whileTrue: [limitClass _ limitClass superclass]. ^ limitClass! ! !Lexicon methodsFor: 'limit class' stamp: 'sw 10/12/2001 21:30'! limitClass "Answer the most generic class to show in the browser. By default, we go all the way up to ProtoObject" ^ limitClass ifNil: [self initialLimitClass]! ! !Lexicon methodsFor: 'limit class' stamp: 'sw 12/13/2000 06:49'! limitClass: aClass "Set the most generic class to show as indicated" limitClass _ aClass! ! !Lexicon methodsFor: 'limit class' stamp: 'sw 3/20/2001 13:07'! limitClassString "Answer a string representing the current choice of most-generic-class-to-show" | most | (most _ self limitClass) == ProtoObject ifTrue: [^ 'All']. most == targetClass ifTrue: [^ most name]. ^ 'Only through ', most name! ! !Lexicon methodsFor: 'limit class' stamp: 'sw 1/12/2001 00:17'! setLimitClass: aClass "Set aClass as the limit class for this browser" | currentClass currentSelector | currentClass _ self selectedClassOrMetaClass. currentSelector _ self selectedMessageName. self limitClass: aClass. categoryList _ nil. self categoryListIndex: 0. self changed: #categoryList. self changed: #methodList. self changed: #contents. self adjustWindowTitle. self hasSearchPane ifTrue: [self setMethodListFromSearchString]. self maybeReselectClass: currentClass selector: currentSelector ! ! !Lexicon methodsFor: 'model glue' stamp: 'sw 3/20/2001 12:11'! doItReceiver "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables. Here, if the receiver is affiliated with a specific instance, we give give that primacy" ^ self targetObject ifNil: [self selectedClass ifNil: [FakeClassPool new]]! ! !Lexicon methodsFor: 'model glue' stamp: 'sw 3/20/2001 10:17'! okayToAccept "Answer whether it is okay to accept the receiver's input" | ok aClass reply | (ok _ super okayToAccept) ifTrue: [((aClass _ self selectedClassOrMetaClass) ~~ targetClass) ifTrue: [reply _ PopUpMenu withCaption: 'Caution!! This would be accepted into class ', aClass name, '. Is that okay?' chooseFrom: {'okay, no problem'. 'cancel - let me reconsider'. 'compile into ', targetClass name, ' instead'. 'compile into a new uniclass'}. reply = 1 ifTrue: [^ true]. reply ~~ 2 ifTrue: [self notYetImplemented]. ^ false]]. ^ ok! ! !Lexicon methodsFor: 'model glue' stamp: 'sw 3/20/2001 12:25'! targetObject "Answer the object to which this tool is bound." ^ nil! ! !Lexicon methodsFor: 'menu commands' stamp: 'sw 11/21/2001 11:01'! offerMenu "Offer a menu to the user, in response to the hitting of the menu button on the tool pane" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Lexicon'. aMenu addStayUpItem. aMenu addList: #( ('vocabulary...' chooseVocabulary) ('what to show...' offerWhatToShowMenu) - ('inst var refs (here)' setLocalInstVarRefs) ('inst var defs (here)' setLocalInstVarDefs) ('class var refs (here)' setLocalClassVarRefs) - ('navigate to a sender...' navigateToASender) ('recent...' navigateToRecentMethod) ('show methods in current change set' showMethodsInCurrentChangeSet) ('show methods with initials...' showMethodsWithInitials) - "('toggle search pane' toggleSearch)" - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('versions (v)' browseVersions) ('inheritance (i)' methodHierarchy) - ('inst var refs' browseInstVarRefs) ('inst var defs' browseInstVarDefs) ('class var refs' browseClassVarRefs) - ('more...' shiftedYellowButtonActivity)). aMenu popUpInWorld: ActiveWorld! ! !Lexicon methodsFor: 'menu commands' stamp: 'sw 3/20/2001 22:23'! removeMessage "Remove the selected message from the system." messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. super removeMessage. "my #reformulateList method, called from the super #removeMethod method, will however try to preserve the selection, so we take pains to clobber it by the below..." messageListIndex _ 0. self changed: #messageList. self changed: #messageListIndex. contents _ nil. self contentsChanged! ! !Lexicon methodsFor: 'menu commands' stamp: 'sw 10/18/2001 08:10'! showCategory "A revectoring blamable on history. Not sent in the image, but grandfathered buttons may still send this." ^ self showHomeCategory! ! !Lexicon methodsFor: 'menu commands' stamp: 'sw 10/8/2001 14:33'! showHomeCategory "Continue to show the current selector, but show it within the context of its primary category" | aSelector | (aSelector _ self selectedMessageName) ifNotNil: [self preserveSelectorIfPossibleSurrounding: [self setToShowSelector: aSelector]]! ! !Lexicon methodsFor: 'menu commands' stamp: 'sw 10/8/2001 14:34'! showMainCategory "Continue to show the current selector, but show it within the context of its primary category. Preserved for backward compatibility with pre-existing buttons." ^ self showHomeCategory! ! !Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12'! browseClassVarRefs "Let the search pertain to the target class regardless of selection" self systemNavigation browseClassVarRefs: targetClass theNonMetaClass ! ! !Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/16/2003 19:43'! browseInstVarDefs "Let the search pertain to the target class regardless of selection" self systemNavigation browseInstVarDefs: targetClass! ! !Lexicon methodsFor: 'new-window queries' stamp: 'sd 4/15/2003 16:12'! browseInstVarRefs "Let the search pertain to the target class regardless of selection" self systemNavigation browseInstVarRefs: targetClass! ! !Lexicon methodsFor: 'search' stamp: 'sw 12/11/2000 15:26'! hasSearchPane "Answer whether receiver has a search pane" ^ self searchPane notNil! ! !Lexicon methodsFor: 'search' stamp: 'sw 3/20/2001 18:55'! lastSearchString "Answer the last search string, initializing it to an empty string if it has not been initialized yet" ^ currentQueryParameter ifNil: [currentQueryParameter _ 'contents']! ! !Lexicon methodsFor: 'search' stamp: 'sw 4/12/2001 00:42'! lastSearchString: aString "Make a note of the last string searched for in the receiver" currentQueryParameter _ aString asString. currentQuery _ #selectorName. autoSelectString _ aString. self setMethodListFromSearchString. ^ true! ! !Lexicon methodsFor: 'search' stamp: 'sw 3/20/2001 19:00'! lastSendersSearchSelector "Answer the last senders search selector, initializing it to a default value if it does not already have a value" ^ currentQueryParameter ifNil: [currentQueryParameter _ #flag:]! ! !Lexicon methodsFor: 'search' stamp: 'NS 12/12/2003 15:58'! methodListFromSearchString: fragment "Answer a method list of methods whose selectors match the given fragment" | aList searchFor | currentQueryParameter _ fragment. currentQuery _ #selectorName. autoSelectString _ fragment. searchFor _ fragment asString asLowercase withBlanksTrimmed. aList _ targetClass allSelectors select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. searchFor size > 0 ifTrue: [aList _ aList select: [:aSelector | aSelector includesSubstring: searchFor caseSensitive: false]]. ^ aList asSortedArray ! ! !Lexicon methodsFor: 'search' stamp: 'sw 4/12/2001 00:50'! obtainNewSearchString "Put up a box allowing the user to enter a fresh search string" | fragment | fragment _ FillInTheBlank request: 'type method name or fragment: ' initialAnswer: self currentQueryParameter. fragment ifNil: [^ self]. (fragment _ fragment copyWithout: $ ) size == 0 ifTrue: [^ self]. currentQueryParameter _ fragment. fragment _ fragment asLowercase. currentQuery _ #selectorName. self showQueryResultsCategory. self messageListIndex: 0! ! !Lexicon methodsFor: 'search' stamp: 'NS 12/12/2003 15:59'! selectorsMatching "Anwer a list of selectors in the receiver that match the current search string" | fragment aList | fragment _ self lastSearchString asLowercase. aList _ targetClass allSelectors select: [:aSelector | (aSelector includesSubstring: fragment caseSensitive: false) and: [currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]]. ^ aList asSortedArray! ! !Lexicon methodsFor: 'search' stamp: 'NS 12/12/2003 15:59'! setMethodListFromSearchString "Set the method list of the receiver based on matches from the search string" | fragment aList | self okToChange ifFalse: [^ self]. fragment _ currentQueryParameter. fragment _ fragment asString asLowercase withBlanksTrimmed. aList _ targetClass allSelectors select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. fragment size > 0 ifTrue: [aList _ aList select: [:aSelector | aSelector includesSubstring: fragment caseSensitive: false]]. aList size == 0 ifTrue: [^ Beeper beep]. self initListFrom: aList asSortedArray highlighting: targetClass. messageListIndex _ messageListIndex min: messageList size. self changed: #messageList ! ! !Lexicon methodsFor: 'search' stamp: 'nb 6/17/2003 12:25'! showSearchPane "Given that the receiver is showing the categories pane, replace that with a search pane. Though there is a residual UI for obtaining this variant, it is obscure and the integrity of the protocol-category-browser when there is no categories pane is not necessarily assured at the moment." | aPane | (aPane _ self categoriesPane) ifNil: [^ Beeper beep]. self containingWindow replacePane: aPane with: self newSearchPane. categoryList _ nil. self changed: #categoryList. self changed: #messageList! ! !Lexicon methodsFor: 'search' stamp: 'sw 12/11/2000 14:46'! toggleSearch "Toggle the determination of whether a categories pane or a search pane shows" self hasSearchPane ifTrue: [self showCategoriesPane] ifFalse: [self showSearchPane]! ! !Lexicon methodsFor: 'selection'! categoryOfSelector: aSelector "Answer the name of the defining category for aSelector, or nil if none" | classDefiningSelector | classDefiningSelector _ targetClass whichClassIncludesSelector: aSelector. classDefiningSelector ifNil: [^ nil]. "can happen for example if one issues this from a change-sorter for a message that is recorded as having been removed" ^ classDefiningSelector whichCategoryIncludesSelector: aSelector! ! !Lexicon methodsFor: 'selection' stamp: 'nk 7/11/2003 06:55'! selectImplementedMessageAndEvaluate: aBlock "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any. In this variant, only selectors " | selector method messages | (selector _ self selectedMessageName) ifNil: [^ self]. method _ (self selectedClassOrMetaClass ifNil: [^ self]) compiledMethodAt: selector ifAbsent: []. (method isNil or: [(messages _ method messages) size == 0]) ifTrue: [^ aBlock value: selector]. (messages size == 1 and: [messages includes: selector]) ifTrue: [^ aBlock value: selector]. "If only one item, there is no choice" messages _ messages select: [:aSelector | currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. self systemNavigation showMenuOf: messages withFirstItem: selector ifChosenDo: [:sel | aBlock value: sel]! ! !Lexicon methodsFor: 'selection' stamp: 'sw 3/19/2001 12:14'! selectSelectorItsNaturalCategory: aSelector "Make aSelector be the current selection of the receiver, with the category being its home category." | cat catIndex detectedItem | cat _ self categoryOfSelector: aSelector. catIndex _ categoryList indexOf: cat ifAbsent: ["The method's own category is not seen in this browser; the method probably occurs in some other category not known directly to the class, but for now, we'll just use the all category" 1]. self categoryListIndex: catIndex. detectedItem _ messageList detect: [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self]. self messageListIndex: (messageList indexOf: detectedItem ifAbsent: [^ self])! ! !Lexicon methodsFor: 'selection' stamp: 'sw 12/14/2000 13:48'! selectWithinCurrentCategory: aSelector "If aSelector is one of the selectors seen in the current category, select it" | detectedItem | detectedItem _ self messageList detect: [:anItem | (anItem asString upTo: $ ) asSymbol == aSelector] ifNone: [^ self]. self messageListIndex: (messageList indexOf: detectedItem ifAbsent: [^ self])! ! !Lexicon methodsFor: 'selection' stamp: 'tk 9/15/2001 08:17'! selectedClassOrMetaClass "Answer the currently selected class (or metaclass)." self setClassAndSelectorIn: [:c :s | ^c]! ! !Lexicon methodsFor: 'selection' stamp: 'nk 6/19/2004 16:46'! selectedMessage "Answer the source method for the currently selected message." (categoryList notNil and: [(categoryListIndex isNil or: [categoryListIndex == 0])]) ifTrue: [^ '---']. self setClassAndSelectorIn: [:class :selector | class ifNil: [^ 'here would go the documentation for the protocol category, if any.']. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. self showingDocumentation ifTrue: [^ self commentContents]. currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil]. ^ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: class]! ! !Lexicon methodsFor: 'selection' stamp: 'tk 9/15/2001 08:14'! setClassAndSelectorIn: csBlock "Decode strings of the form <selectorName> (<className> [class])" self selection ifNil: [^ csBlock value: targetClass value: nil]. ^ super setClassAndSelectorIn: csBlock! ! !Lexicon methodsFor: 'selection' stamp: 'sw 1/26/2001 19:42'! setToShowSelector: aSelector "Set up the receiver so that it will show the given selector" | catName catIndex detectedItem messageIndex aList | catName _ (aList _ currentVocabulary categoriesContaining: aSelector forClass: targetClass) size > 0 ifTrue: [aList first] ifFalse: [self class allCategoryName]. catIndex _ categoryList indexOf: catName ifAbsent: [1]. self categoryListIndex: catIndex. detectedItem _ messageList detect: [:anItem | (anItem upTo: $ ) asString asSymbol == aSelector] ifNone: [^ self]. messageIndex _ messageList indexOf: detectedItem. self messageListIndex: messageIndex ! ! !Lexicon methodsFor: 'senders' stamp: 'md 10/22/2003 16:15'! navigateToASender "Present the user with a list of senders of the currently-selected message, and navigate to the chosen one" | selectorSet chosen aSelector | aSelector _ self selectedMessageName. selectorSet _ Set new. (self systemNavigation allCallsOn: aSelector) do: [:anItem | selectorSet add: anItem methodSymbol]. selectorSet _ selectorSet select: [:sel | currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. selectorSet size == 0 ifTrue: [^ Beeper beep]. self okToChange ifFalse: [^ self]. chosen _ (SelectionMenu selections: selectorSet asSortedArray) startUp. chosen isEmptyOrNil ifFalse: [self displaySelector: chosen]! ! !Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:16'! selectorsSendingSelectedSelector "Assumes lastSendersSearchSelector is already set" | selectorSet sel cl | autoSelectString _ (self lastSendersSearchSelector upTo: $:) asString. selectorSet _ Set new. (self systemNavigation allCallsOn: self lastSendersSearchSelector) do: [:anItem | sel _ anItem methodSymbol. cl _ anItem actualClass. ((currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass) and: [targetClass includesBehavior: cl]) ifTrue: [selectorSet add: sel]]. ^ selectorSet asSortedArray! ! !Lexicon methodsFor: 'senders' stamp: 'sd 4/29/2003 12:16'! setSendersSearch "Put up a list of messages sent in the current message, find all methods of the browsee which send the one the user chooses, and show that list in the message-list pane, with the 'query results' item selected in the category-list pane" | selectorSet aSelector aString | self selectedMessageName ifNil: [aString _ FillInTheBlank request: 'Type selector to search for' initialAnswer: 'flag:'. aString isEmptyOrNil ifTrue: [^ self]. Symbol hasInterned: aString ifTrue: [:sel | aSelector _ sel]] ifNotNil: [self selectMessageAndEvaluate: [:sel | aSelector _ sel]]. aSelector ifNil: [^ self]. selectorSet _ Set new. (self systemNavigation allCallsOn: aSelector) do: [:anItem | selectorSet add: anItem methodSymbol]. selectorSet _ selectorSet select: [:sel | currentVocabulary includesSelector: sel forInstance: self targetObject ofClass: targetClass limitClass: limitClass]. selectorSet size > 0 ifTrue: [currentQuery _ #senders. currentQueryParameter _ aSelector. self categoryListIndex: (categoryList indexOf: self class queryCategoryName). self messageListIndex: 0]! ! !Lexicon methodsFor: 'transition' stamp: 'sw 3/20/2001 12:11'! maybeReselectClass: aClass selector: aSelector "The protocol or limitClass may have changed, so that there is a different categoryList. Formerly, the given class and selector were selected; if it is possible to do so, reselect them now" aClass ifNil: [^ self]. (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) ifTrue: [self selectSelectorItsNaturalCategory: aSelector]! ! !Lexicon methodsFor: 'transition' stamp: 'sw 3/20/2001 00:41'! noteAcceptanceOfCodeFor: newSelector "The user has submitted new code for the given selector; take a note of it. NB that the selectors-changed list gets added to here, but is not currently used in the system." (self selectorsVisited includes: newSelector) ifFalse: [selectorsVisited add: newSelector].! ! !Lexicon methodsFor: 'transition' stamp: 'sw 12/11/2000 14:46'! preserveSelectorIfPossibleSurrounding: aBlock "Make a note of the currently-selected method; perform aBlock and then attempt to reestablish that same method as the selected one in the new circumstances" | aClass aSelector | aClass _ self selectedClassOrMetaClass. aSelector _ self selectedMessageName. aBlock value. self hasSearchPane ifTrue: [self setMethodListFromSearchString] ifFalse: [self maybeReselectClass: aClass selector: aSelector]! ! !Lexicon methodsFor: 'transition' stamp: 'sw 12/11/2000 02:00'! reformulateList "Make the category list afresh, and reselect the current selector if appropriate" self preserveSelectorIfPossibleSurrounding: [super reformulateList. self categoryListIndex: categoryListIndex]! ! !Lexicon methodsFor: 'transition' stamp: 'sw 1/12/2001 00:33'! reformulateListNoting: newSelector "A method has possibly been submitted for the receiver with newSelector as its selector; If the receiver has a way of reformulating its message list, here is a chance for it to do so" super reformulateListNoting: newSelector. newSelector ifNotNil: [self displaySelector: newSelector]! ! !Lexicon methodsFor: 'transition' stamp: 'sw 12/19/2000 18:27'! retainMethodSelectionWhileSwitchingToCategory: aCategoryName "retain method selection while switching the category-pane selection to show the category of the given name" | aSelectedName | aSelectedName _ self selectedMessageName. self categoryListIndex: (categoryList indexOf: aCategoryName ifAbsent: [^ self]). aSelectedName ifNotNil: [self selectWithinCurrentCategory: aSelectedName] ! ! !Lexicon methodsFor: 'vocabulary' stamp: 'yo 1/14/2005 19:57'! chooseVocabulary "Put up a dialog affording the user a chance to choose a different vocabulary to be installed in the receiver" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Choose a vocabulary blue = current red = imperfect' translated. aMenu addStayUpItem. Vocabulary allStandardVocabularies do: [:aVocabulary | (targetClass implementsVocabulary: aVocabulary) ifTrue: [aMenu add: aVocabulary vocabularyName selector: #switchToVocabulary: argument: aVocabulary. (targetClass fullyImplementsVocabulary: aVocabulary) ifFalse: [aMenu lastItem color: Color red]. aVocabulary == currentVocabulary ifTrue: [aMenu lastItem color: Color blue]. aMenu balloonTextForLastItem: aVocabulary documentation]]. aMenu popUpInWorld: self currentWorld! ! !Lexicon methodsFor: 'vocabulary' stamp: 'sw 1/26/2001 19:40'! switchToVocabulary: aVocabulary "Make aVocabulary be the current one in the receiver" self preserveSelectorIfPossibleSurrounding: [self useVocabulary: aVocabulary. self reformulateCategoryList. self adjustWindowTitle] ! ! !Lexicon methodsFor: 'vocabulary' stamp: 'sw 1/26/2001 19:37'! useVocabulary: aVocabulary "Set up the receiver to use the given vocabulary" currentVocabulary _ aVocabulary! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 18:59'! currentQueryParameter "Answer the current query parameter" ^ currentQueryParameter ifNil: [currentQueryParameter _ 'contents']! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:48'! methodsWithInitials "Answer the list of method selectors within the scope of this tool whose time stamps begin with the initials designated by my currentQueryParameter" ^ self methodsWithInitials: currentQueryParameter! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'NS 12/12/2003 15:58'! methodsWithInitials: initials "Return a list of selectors representing methods whose timestamps have the given initials and which are in the protocol of this object and within the range dictated by my limitClass." | classToUse | classToUse _ self targetObject ifNotNil: [self targetObject class] ifNil: [targetClass]. "In support of lightweight uniclasses" ^ targetClass allSelectors select: [:aSelector | (currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: classToUse limitClass: limitClass) and: [Utilities doesMethod: aSelector forClass: classToUse bearInitials: initials]]. ! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 7/23/2002 12:43'! queryCharacterization "Answer a characterization of the most recent query" currentQuery == #selectorName ifTrue: [^ 'My methods whose names include "', self lastSearchString, '"']. currentQuery == #methodsWithInitials ifTrue: [^ 'My methods stamped with initials ', currentQueryParameter]. currentQuery == #senders ifTrue: [^ 'My methods that send #', self lastSendersSearchSelector]. currentQuery == #currentChangeSet ifTrue: [^ 'My methods in the current change set']. currentQuery == #instVarRefs ifTrue: [^ 'My methods that refer to instance variable "', currentQueryParameter, '"']. currentQuery == #instVarDefs ifTrue: [^ 'My methods that store into instance variable "', currentQueryParameter, '"']. currentQuery == #classVarRefs ifTrue: [^ 'My methods that refer to class variable "', currentQueryParameter, '"']. ^ 'Results of queries will show up here'! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'md 10/22/2003 16:14'! seeAlso "Present a menu offering the selector of the currently selected message, as well as of all messages sent by it. If the chosen selector is showable in the current browser, show it here, minding unsubmitted edits however" self selectImplementedMessageAndEvaluate: [:aSelector | ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is this aSelector available in this browser" and: [self okToChange]) ifTrue: [self displaySelector: aSelector] ifFalse: [Beeper beep. "SysttemNavigation new browseAllImplementorsOf: aSelector"]]. "Initially I tried making this open an external implementors browser in this case, but later decided that the user model for this was unstable"! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'nb 6/17/2003 12:25'! seeAlso: aSelector "If the requested selector is showable in the current browser, show it here, minding unsubmitted edits however" ((currentVocabulary includesSelector: aSelector forInstance: self targetObject ofClass: targetClass limitClass: limitClass) "i.e., is aSelector available in this browser" and: [self okToChange]) ifTrue: [self displaySelector: aSelector] ifFalse: [Beeper beep]! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sd 5/23/2003 14:38'! selectorsChanged "Return a list of methods in the current change set (or satisfying some other such criterion) that are in the protocol of this object" | aList aClass targetedClass | targetedClass _ self targetObject ifNil: [targetClass] ifNotNil: [self targetObject class]. aList _ OrderedCollection new. ChangeSet current methodChanges associationsDo: [:classChgAssoc | classChgAssoc value associationsDo: [:methodChgAssoc | (methodChgAssoc value == #change or: [methodChgAssoc value == #add]) ifTrue: [(aClass _ targetedClass whichClassIncludesSelector: methodChgAssoc key) ifNotNil: [aClass name = classChgAssoc key ifTrue: [aList add: methodChgAssoc key]]]]]. ^ aList! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:22'! selectorsDefiningInstVar "Return a list of methods that define a given inst var that are in the protocol of this object" | aList | aList _ OrderedCollection new. targetClass withAllSuperclassesDo: [:aClass | (aClass whichSelectorsStoreInto: currentQueryParameter asString) do: [:sel | sel ~~ #DoIt ifTrue: [aList add: sel]]]. ^ aList! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:14'! selectorsReferringToInstVar "Return a list of methods that refer to a given inst var that are in the protocol of this object" | aList | aList _ OrderedCollection new. targetClass withAllSuperclassesDo: [:aClass | (aClass whichSelectorsAccess: currentQueryParameter asString) do: [:sel | sel ~~ #DoIt ifTrue: [aList add: sel]]]. ^ aList! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:53'! selectorsRetrieved "Anwer a list of selectors in the receiver that have been retrieved for the query category. This protocol is used when reformulating a list after, say, a limitClass change" currentQuery == #classVarRefs ifTrue: [^ self selectorsReferringToClassVar]. currentQuery == #currentChangeSet ifTrue: [^ self selectorsChanged]. currentQuery == #instVarDefs ifTrue: [^ self selectorsDefiningInstVar]. currentQuery == #instVarRefs ifTrue: [^ self selectorsReferringToInstVar]. currentQuery == #methodsWithInitials ifTrue: [^ self methodsWithInitials]. currentQuery == #selectorName ifTrue: [^ self selectorsMatching]. currentQuery == #senders ifTrue: [^ self selectorsSendingSelectedSelector]. ^ #()! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 4/4/2001 00:15'! setLocalClassVarRefs "Put up a list of the class variables in the viewed object, and when the user selects one, let the query results category show all the references to that class variable." | aName | (aName _ targetClass theNonMetaClass chooseClassVarName) ifNil: [^ self]. currentQuery _ #classVarRefs. currentQueryParameter _ aName. self showQueryResultsCategory! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:21'! setLocalInstVarDefs "Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable." | instVarToProbe | targetClass chooseInstVarThenDo: [:aName | instVarToProbe _ aName]. instVarToProbe isEmptyOrNil ifTrue: [^ self]. currentQuery _ #instVarDefs. currentQueryParameter _ instVarToProbe. self showQueryResultsCategory! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:16'! setLocalInstVarRefs "Put up a list of the instance variables in the viewed object, and when the user seletcts one, let the query results category show all the references to that instance variable." | instVarToProbe | targetClass chooseInstVarThenDo: [:aName | instVarToProbe _ aName]. instVarToProbe isEmptyOrNil ifTrue: [^ self]. currentQuery _ #instVarRefs. currentQueryParameter _ instVarToProbe. self showQueryResultsCategory! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 11:19'! showMethodsInCurrentChangeSet "Set the current query to be for methods in the current change set" currentQuery _ #currentChangeSet. autoSelectString _ nil. self categoryListIndex: (categoryList indexOf: self class queryCategoryName).! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:46'! showMethodsWithInitials "Prompt the user for initials to scan for; then show, in the query-results category, all methods with those initials in their time stamps" | initials | initials _ FillInTheBlank request: 'whose initials? ' initialAnswer: Utilities authorInitials. initials isEmptyOrNil ifTrue: [^ self]. self showMethodsWithInitials: initials ! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 11/21/2001 10:44'! showMethodsWithInitials: initials "Make the current query be for methods stamped with the given initials" currentQuery _ #methodsWithInitials. currentQueryParameter _ initials. self showQueryResultsCategory. autoSelectString _ nil. self changed: #messageList. self adjustWindowTitle ! ! !Lexicon methodsFor: 'within-tool queries' stamp: 'sw 3/20/2001 20:16'! showQueryResultsCategory "Point the receiver at the query-results category and set the search string accordingly" autoSelectString _ self currentQueryParameter. self categoryListIndex: (categoryList indexOf: self class queryCategoryName). self messageListIndex: 0! ! !Lexicon methodsFor: 'window title' stamp: 'sw 3/19/2001 08:45'! addModelItemsToWindowMenu: aMenu "Add model-related item to the window menu" super addModelItemsToWindowMenu: aMenu. aMenu add: 'choose vocabulary...' target: self action: #chooseVocabulary! ! !Lexicon methodsFor: 'window title' stamp: 'sw 3/20/2001 16:42'! adjustWindowTitle "Set the title of the receiver's window, if any, to reflect the current choices" | aWindow aLabel catName | (catName _ self selectedCategoryName) ifNil: [^ self]. (aWindow _ self containingWindow) ifNil: [^ self]. aLabel _ nil. #( (viewedCategoryName 'Messages already viewed - ') (allCategoryName 'All messages - ')) do: [:aPair | catName = (self categoryWithNameSpecifiedBy: aPair first) ifTrue: [aLabel _ aPair second]]. aLabel ifNil: [aLabel _ catName = self class queryCategoryName ifTrue: [self queryCharacterization, ' - '] ifFalse: ['Vocabulary of ']]. aWindow setLabel: aLabel, (self targetObject ifNil: [targetClass]) nameForViewer! ! !Lexicon methodsFor: 'window title' stamp: 'sw 3/20/2001 12:18'! startingWindowTitle "Answer the initial window title to apply" ^ 'Vocabulary of ', targetClass nameForViewer! ! !Lexicon methodsFor: 'message list menu' stamp: 'sw 4/20/2001 20:54'! messageListKey: aChar from: view "Respond to a Command key" aChar == $f ifTrue: [^ self obtainNewSearchString]. ^ super messageListKey: aChar from: view! ! !Lexicon methodsFor: 'contents' stamp: 'tk 9/14/2001 16:37'! contents "We have a class, allow new messages to be defined" editSelection == #newMessage ifTrue: [^ targetClass sourceCodeTemplate]. ^ super contents! ! !Lexicon methodsFor: 'tiles' stamp: 'nb 6/17/2003 12:25'! acceptTiles | pp pq methodNode cls sel | "In complete violation of all the rules of pluggable panes, search dependents for my tiles, and tell them to accept." pp _ self dependents detect: [:pane | pane isKindOf: PluggableTileScriptorMorph] ifNone: [^ Beeper beep]. pq _ pp findA: TransformMorph. methodNode _ pq findA: SyntaxMorph. cls _ methodNode parsedInClass. sel _ cls compile: methodNode decompile classified: self selectedCategoryName notifying: nil. self noteAcceptanceOfCodeFor: sel. self reformulateListNoting: sel.! ! !Lexicon methodsFor: 'tiles' stamp: 'nk 4/28/2004 10:15'! installTilesForSelection "Install universal tiles into the code pane." | source aSelector aClass tree syn tileScriptor aWindow codePane | (aWindow _ self containingWindow) ifNil: [self error: 'hamna dirisha']. aSelector _ self selectedMessageName. aClass _ self selectedClassOrMetaClass ifNil: [targetClass]. aClass ifNotNil: [aSelector ifNil: [source _ SyntaxMorph sourceCodeTemplate] ifNotNil: [aClass _ self selectedClassOrMetaClass whichClassIncludesSelector: aSelector. source _ aClass sourceCodeAt: aSelector]. tree _ Compiler new parse: source in: aClass notifying: nil. (syn _ tree asMorphicSyntaxUsing: SyntaxMorph) parsedInClass: aClass. tileScriptor _ syn inAPluggableScrollPane]. codePane _ aWindow findDeepSubmorphThat: [:m | (m isKindOf: PluggableTextMorph) and: [m getTextSelector == #contents]] ifAbsent: []. codePane ifNotNil: [codePane hideScrollBars]. codePane ifNil: [codePane _ aWindow findDeepSubmorphThat: [:m | m isKindOf: PluggableTileScriptorMorph] ifAbsent: [self error: 'no code pane']]. tileScriptor color: aWindow paneColorToUse; setProperty: #hideUnneededScrollbars toValue: true. aWindow replacePane: codePane with: tileScriptor. currentCompiledMethod _ aClass ifNotNil: [aClass compiledMethodAt: aSelector ifAbsent: []]. tileScriptor owner clipSubmorphs: true. tileScriptor extent: codePane extent! ! !Lexicon methodsFor: 'tiles' stamp: 'tk 9/7/2001 10:15'! tilesMenu "Offer a menu of tiles for assignment and constants" SyntaxMorph new offerTilesMenuFor: self targetObject in: self! ! !Lexicon methodsFor: 'tiles' stamp: 'tk 9/7/2001 10:24'! varTilesMenu "Offer a menu of tiles for instance variables and a new temporary" SyntaxMorph new offerVarsMenuFor: self targetObject in: self! ! !Lexicon methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:25'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ true! ! !Lexicon methodsFor: 'controls' stamp: 'sw 7/23/2002 12:55'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "In this case we may actually add TWO rows of buttons." | delta buttons divider anOffset | anOffset _ Preferences optionalButtons ifTrue: [super addOptionalButtonsTo: window at: fractions plus: verticalOffset] ifFalse: [verticalOffset]. delta _ self defaultButtonPaneHeight. buttons _ self customButtonRow. buttons color: (Display depth <= 8 ifTrue: [Color transparent] ifFalse: [Color gray alpha: 0.2]); borderWidth: 0. Preferences alternativeWindowLook ifTrue: [buttons color: Color transparent. buttons submorphsDo:[:m | m borderWidth: 2; borderColor: #raised]]. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue: [divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2]. window addMorph: buttons fullFrame: (LayoutFrame fractions: fractions offsets: (0@anOffset corner: 0@(anOffset + delta - 1))). window addMorph: divider fullFrame: (LayoutFrame fractions: fractions offsets: (0@(anOffset + delta - 1) corner: 0@(anOffset + delta))). ^ anOffset + delta! ! !Lexicon commentStamp: '<historical>' prior: 0! An instance of Lexicon shows the a list of all the method categories known to an object or any of its superclasses, as a "flattened" list, and, within any selected category, shows all methods understood by the class's instances which are associated with that category, again as a "flattened" list. A variant with a search pane rather than a category list is also implemented. categoryList the list of categories categoryListIndex index of currently-selected category targetObject optional -- an instance being viewed targetClass the class being viewed lastSearchString the last string searched for lastSendersSearchSelector the last senders search selector limitClass optional -- the limit class to search for selectorsVisited list of selectors visited selectorsActive not presently in use, subsumed by selectorsVisited currentVocabulary the vocabulary currently installed currentQuery what the query category relates to: #senders #selectorName #currentChangeSet! !Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/14/2000 14:15'! activeCategoryName "Answer the name to be used for the active-methods category" true ifTrue: [^ #'-- current working set --']. '-- current working set --' asSymbol "Placed here so a message-strings-containing-it query will find this method" ! ! !Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/13/2000 10:56'! allCategoryName "Answer the name to be used for the all category" true ifTrue: [^ #'-- all --']. '-- all --' asSymbol "Placed here so a message-strings-containing-it query will find this method" ! ! !Lexicon class methodsFor: 'visible category names' stamp: 'sw 3/19/2001 08:17'! queryCategoryName "Answer the name to be used for the query-results category" true ifTrue: [^ #'-- query results --']. ^ '-- query results --' asSymbol "Placed here so a message-strings-containing-it query will find this method"! ! !Lexicon class methodsFor: 'visible category names' stamp: 'sw 12/13/2000 10:54'! sendersCategoryName "Answer the name to be used for the senders-results category" true ifTrue: [^ #'-- "senders" results --']. ^ '-- "senders" results --'. "so methods-strings-containing will find this"! ! !Lexicon class methodsFor: 'visible category names' stamp: 'sw 3/19/2001 08:03'! viewedCategoryName "Answer the name to be used for the previously-viewed-methods category" true ifTrue: [^ #'-- active --']. ^ '-- active --' asSymbol "For benefit of method-strings-containing-it search" ! ! !Lexicon class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:35'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Lexicon' brightColor: #(0.878 1.000 0.878) pastelColor: #(0.925 1.000 0.925) helpMessage: 'A tool for browsing the full protocol of a class.'! ! !LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'BG 3/13/2004 13:18'! nextPutAll: aCollection | newEnd | collection class == aCollection class ifFalse: [^ super nextPutAll: aCollection ]. newEnd _ position + aCollection size. newEnd > limit ifTrue: [ super nextPutAll: (aCollection copyFrom: 1 to: (limit - position max: 0)). ^ limitBlock value. ]. newEnd > writeLimit ifTrue: [ self growTo: newEnd + 10 ]. collection replaceFrom: position+1 to: newEnd with: aCollection startingAt: 1. position _ newEnd.! ! !LimitedWriteStream methodsFor: 'as yet unclassified' stamp: 'di 10/28/2001 12:49'! pastEndPut: anObject collection size >= limit ifTrue: [limitBlock value]. "Exceptional return" ^ super pastEndPut: anObject! ! !LimitedWriteStream methodsFor: 'accessing' stamp: 'BG 3/13/2004 16:03'! nextPut: anObject "Ensure that the limit is not exceeded" position >= limit ifTrue: [limitBlock value] ifFalse: [super nextPut: anObject]. ! ! !LineMorph class methodsFor: 'new-morph participation' stamp: 'sw 11/13/2001 14:37'! newStandAlone "Answer a suitable instance for use in a parts bin, for example" ^ self new setNameTo: 'Line'! ! !LineMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! descriptionForPartsBin ^ self partName: 'Line' categories: #('Graphics' 'Basic') documentation: 'A straight line. Shift-click to get handles and move the ends.'! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'! direction ^end - start! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 5/23/2001 18:27'! sideOfPoint: aPoint "Return the side of the receiver this point is on. The method returns -1: if aPoint is left 0: if aPoint is on +1: if a point is right of the receiver." | dx dy px py | dx _ end x - start x. dy _ end y - start y. px _ aPoint x - start x. py _ aPoint y - start y. ^((dx * py) - (px * dy)) sign " (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@-50. (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@50. (LineSegment from: 0@0 to: 100@0) sideOfPoint: 50@0. " ! ! !LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 12:49'! computeForm: char | ttGlyph scale | char = Character tab ifTrue: [^ super computeForm: char]. "char = $U ifTrue: [self doOnlyOnce: [self halt]]." scale _ self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender). ttGlyph _ ttcDescription at: char. ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis! ! !LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/6/2004 19:56'! emphasis ^ emphasis. ! ! !LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/6/2004 19:18'! emphasis: code emphasis _ code. ! ! !LinedTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 11:26'! lineGlyph: aGlyph lineGlyph _ aGlyph. contourWidth _ aGlyph calculateWidth. ! ! !LinedTTCFont class methodsFor: 'as yet unclassified' stamp: 'yo 5/7/2004 07:32'! fromTTCFont: aTTCFont emphasis: code | inst | inst _ self new. inst ttcDescription: aTTCFont ttcDescription. inst pointSize: aTTCFont pointSize. inst recreateCache. inst emphasis: (aTTCFont emphasis bitOr: code). inst lineGlyph: (aTTCFont ttcDescription at: $_). ^ inst. ! ! !LinkedList methodsFor: 'accessing' stamp: 'ajh 8/6/2002 15:46'! at: index | i | i _ 0. self do: [:link | (i _ i + 1) = index ifTrue: [^ link]]. ^ self errorSubscriptBounds: index! ! !LinkedList methodsFor: 'adding' stamp: 'md 10/13/2004 13:50'! add: link after: otherLink "Add otherLink after link in the list. Answer aLink." | savedLink | savedLink := otherLink nextLink. otherLink nextLink: link. link nextLink: savedLink. ^link.! ! !LinkedList methodsFor: 'adding' stamp: 'ajh 8/22/2002 14:17'! add: link before: otherLink | aLink | firstLink == otherLink ifTrue: [^ self addFirst: link]. aLink _ firstLink. [aLink == nil] whileFalse: [ aLink nextLink == otherLink ifTrue: [ link nextLink: aLink nextLink. aLink nextLink: link. ^ link ]. aLink _ aLink nextLink. ]. ^ self errorNotFound: otherLink! ! !LinkedList methodsFor: 'enumerating' stamp: 'ajh 8/6/2002 16:39'! species ^ Array! ! !LinkedListTest methodsFor: 'acessing' stamp: 'md 10/14/2004 10:47'! n ^n! ! !LinkedListTest methodsFor: 'acessing' stamp: 'md 10/14/2004 10:47'! n: number n := number. ! ! !LinkedListTest methodsFor: 'acessing' stamp: 'md 10/14/2004 10:46'! nextLink ^nextLink! ! !LinkedListTest methodsFor: 'acessing' stamp: 'md 10/14/2004 10:46'! nextLink: aLink nextLink := aLink! ! !LinkedListTest methodsFor: 'testing' stamp: 'MD 10/14/2004 11:05'! testAddAfter | l first | l := LinkedList new. first := self class new n: 1. l add: first. l add: (self class new n: 3). self assert: (l collect:[:e | e n]) asArray = #(1 3). l add: (self class new n: 2) after: first. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LinkedListTest methodsFor: 'testing' stamp: 'MD 10/14/2004 11:04'! testAddAfterLast | l last | l := LinkedList new. last := self class new n: 2. l add: (self class new n: 1). l add: last. self assert: (l collect:[:e | e n]) asArray = #(1 2). l add: (self class new n: 3) after: last. self assert: (l collect:[:e | e n]) asArray = #(1 2 3).! ! !LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:34'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color black! ! !LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !LipsMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:18'! initialize "initialize the state of the receiver" super initialize. "" self beSmoothCurve. vertices _ {11 @ 3. 35 @ 1. 60 @ 5. 67 @ 17. 34 @ 24. 3 @ 17}. closed _ true. self neutral; updateShape! ! !ListComponent methodsFor: 'components' stamp: 'gm 2/27/2003 23:19'! initFromPinSpecs | ioPin | getListSelector := pinSpecs first modelReadSelector. ioPin := pinSpecs second. getIndexSelector := ioPin isInput ifTrue: [ioPin modelReadSelector] ifFalse: [nil]. setIndexSelector := ioPin isOutput ifTrue: [ioPin modelWriteSelector] ifFalse: [nil]. setSelectionSelector := pinSpecs third modelWriteSelector! ! !ListComponent methodsFor: 'model access' stamp: 'ls 5/17/2001 23:07'! changeModelSelection: anInteger "Change the model's selected item index to be anInteger." setIndexSelector ifNil: ["If model is not hooked up to index, then we won't get an update, so have to do it locally." self selectionIndex: anInteger] ifNotNil: [model perform: setIndexSelector with: anInteger]. selectedItem _ anInteger = 0 ifTrue: [nil] ifFalse: [self getListItem: anInteger]. setSelectionSelector ifNotNil: [model perform: setSelectionSelector with: selectedItem]! ! !ListParagraph class methodsFor: 'initialization' stamp: 'nk 9/1/2004 10:27'! initialize "ListParagraph initialize" | aFont | "Allow different line spacing for lists" aFont _ Preferences standardListFont. ListStyle _ TextStyle fontArray: { aFont }. ListStyle gridForFont: 1 withLead: 1! ! !ListViewLine methodsFor: 'thumbnail' stamp: 'sw 10/6/2002 02:00'! morphRepresented "Answer the morph that I actually represent" ^ objectRepresented! ! !LiteralNode methodsFor: 'printing' stamp: 'ar 8/16/2001 13:27'! printOn: aStream indent: level (key isVariableBinding) ifTrue: [key key isNil ifTrue: [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] ifFalse: [aStream nextPutAll: '##'; nextPutAll: key key]] ifFalse: [aStream withStyleFor: #literal do: [key storeOn: aStream]]! ! !LiteralNode methodsFor: 'tiles' stamp: 'tk 8/24/2001 15:43'! asMorphicSyntaxIn: parent | row | row _ parent addRow: #literal on: self. (key isVariableBinding) ifFalse: [ row layoutInset: 1. ^ row addMorphBack: (row addString: key storeString special: false)]. key key isNil ifTrue: [ ^ row addTextRow: ('###',key value soleInstance name) ] ifFalse: [ ^ row addTextRow: ('##', key key) ]. ! ! !LiteralNode methodsFor: 'tiles' stamp: 'ar 8/16/2001 13:27'! explanation (key isVariableBinding) ifFalse: [ ^'Literal ', key storeString ]. key key isNil ifTrue: [ ^'Literal ', ('###',key value soleInstance name) ] ifFalse: [ ^'Literal ', ('##', key key) ]. ! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:41'! emitLoad: stack on: strm splNode ifNil:[^super emitLoad: stack on: strm]. self code < 256 ifTrue: [strm nextPut: self code] ifFalse: [self emitLong: LoadLong on: strm]. stack push: 1.! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/16/2001 12:12'! emitStore: stack on: strm splNode ifNil:[^super emitStore: stack on: strm]. splNode emit: stack args: 1 on: strm super: false.! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'ar 8/16/2001 12:12'! emitStorePop: stack on: strm splNode ifNil:[^super emitStorePop: stack on: strm]. self emitStore: stack on: strm. strm nextPut: Pop. stack pop: 1.! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'! sizeForStore: encoder | index | (self key isVariableBinding and:[self key isSpecialWriteBinding]) ifFalse:[^super sizeForStore: encoder]. self code < 0 ifTrue:[ index _ self index. self code: (self code: index type: LdLitType)]. splNode _ encoder encodeSelector: #value:. ^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder)! ! !LiteralVariableNode methodsFor: 'code generation' stamp: 'ab 7/13/2004 13:52'! sizeForStorePop: encoder | index | (self key isVariableBinding and:[self key isSpecialWriteBinding]) ifFalse:[^super sizeForStorePop: encoder]. self code < 0 ifTrue:[ index _ self index. self code: (self code: index type: LdLitType)]. splNode _ encoder encodeSelector: #value:. ^ (splNode size: encoder args: 1 super: false) + (super sizeForValue: encoder) + 1! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:51'! primCountry "Returns string with country (sub)tag according to ISO 639"! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 19:00'! primCurrencyNotation "Returns boolean if symbol is pre- (true) or post-fix (false)" ^true! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 19:00'! primCurrencySymbol "Returns string with currency symbol" ^'$'! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:57'! primDST "Returns boolean if DST (daylight saving time) is active or not" ^false! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:58'! primDecimalSymbol "Returns string with e.g. '.' or ','" ^'.'! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:58'! primDigitGrouping "Returns string with e.g. '.' or ',' (thousands etc)" ^','! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:51'! primLanguage "returns string with language tag according to ISO 639" ! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:59'! primLongDateFormat "Returns the long date format d day, m month, y year, double symbol is null padded, single not padded (m=6, mm=06) dddd weekday mmmm month name"! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 19:00'! primMeasurement "Returns string denoting metric or imperial." ^'imperial' ! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:59'! primShortSateFormat "Returns the short date format d day, m month, y year, double symbol is null padded, single not padded (m=6, mm=06) dddd weekday mmmm month name"! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:59'! primTimeTormat "Returns string time format Format is made up of h hour (h 12, H 24), m minute, s seconds, x (am/pm String) double symbol is null padded, single not padded (h=6, hh=06)" ! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:56'! primTimezone "The offset from UTC in seconds, with positive offsets being towards the east. (San Francisco is in UTC -08*60 and Paris is in GMT +01*60 (daylight savings is not in effect)." ^0! ! !Locale methodsFor: 'system primitives' stamp: 'mir 5/13/2004 18:57'! primVMOffsetToUTC "Returns the offset in seconds between the VM and UTC. If the VM does not support UTC times, this is 0. Also gives us backward compatibility with old VMs as the primitive will fail and we then can return 0." ^0! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoCountry ^self localeID isoCountry! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoLanguage ^self localeID isoLanguage! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:41'! isoLocale "<language>-<country>" ^self isoCountry ifNil: [self isoLanguage] ifNotNil: [self isoLanguage , '-' , self isoCountry]! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:52'! languageEnvironment ^LanguageEnvironment localeID: self localeID! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID ^id! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID: anID id := anID! ! !Locale commentStamp: '<historical>' prior: 0! Main comment stating the purpose of this class and relevant relationship to other classes. http://www.w3.org/WAI/ER/IG/ert/iso639.htm http://www.oasis-open.org/cover/iso639a.html See also http://oss.software.ibm.com/cvs/icu/~checkout~/icuhtml/design/language_code_issues.html http://www.w3.org/Protocols/rfc2616/rfc2616-sec3.html#sec3.10 ISO 3166 http://mitglied.lycos.de/buran/knowhow/codes/locales/ ! !Locale class methodsFor: 'accessing' stamp: 'mir 8/16/2003 16:02'! clipboadInterpreter ^NoConversionClipboardInterpreter new! ! !Locale class methodsFor: 'accessing' stamp: 'mir 8/18/2003 17:45'! current "Current := nil" Current ifNil: [Current := self determineCurrentLocale]. ^Current! ! !Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:32'! currentPlatform "CurrentPlatform := nil" CurrentPlatform ifNil: [CurrentPlatform := self determineCurrentLocale]. ^CurrentPlatform! ! !Locale class methodsFor: 'accessing' stamp: 'yo 7/28/2004 20:39'! currentPlatform: locale CurrentPlatform := locale. LanguageEnvironment startUp. ! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:20'! isoLanguage: isoLanguage ^self isoLanguage: isoLanguage isoCountry: nil! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:31'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:42'! isoLocale: aString ! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/13/2004 00:24'! languageSymbol: languageSymbol "Locale languageSymbol: #Deutsch" ^self isoLanguage: (LanguageSymbols at: languageSymbol)! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:30'! localeID: id ^self knownLocales at: id ifAbsentPut: [Locale new localeID: id]! ! !Locale class methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'! stringForLanguageNameIs: localeID "Answer a string for a menu determining whether the given symbol is the project's natural language" ^ (self current localeID = localeID ifTrue: ['<yes>'] ifFalse: ['<no>']) , localeID displayName! ! !Locale class methodsFor: 'accessing' stamp: 'yo 2/24/2005 20:21'! switchTo: locale "Locale switchTo: Locale isoLanguage: 'de' " Current := locale. CurrentPlatform := locale. self localeChanged! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 19:07'! switchToID: localeID "Locale switchToID: (LocaleID isoLanguage: 'de') " self switchTo: (Locale localeID: localeID)! ! !Locale class methodsFor: 'platform specific' stamp: 'nk 7/30/2004 21:45'! defaultEncodingName: languageSymbol | encodings platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. encodings := self platformEncodings at: languageSymbol ifAbsent: [self platformEncodings at: #default]. encodings at: platformName ifPresent: [:encoding | ^encoding]. encodings at: platformName , ' ' , osVersion ifPresent: [:encoding | ^encoding]. ^encodings at: #default! ! !Locale class methodsFor: 'platform specific' stamp: 'nk 7/30/2004 21:45'! defaultInputInterpreter | platformName osVersion | platformName := SmalltalkImage current platformName. osVersion := SmalltalkImage current getSystemAttribute: 1002. (platformName = 'Win32' and: [osVersion = 'CE']) ifTrue: [^NoInputInterpreter new]. platformName = 'Win32' ifTrue: [^MacRomanInputInterpreter new]. ^NoInputInterpreter new! ! !Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 14:55'! determineCurrentLocale "For now just return the default locale. A smarter way would be to determine the current platforms default locale." ^self localeID: LocaleID default! ! !Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 19:44'! initKnownLocales | locales | locales := Dictionary new. "Init the locales for which we have translations" NaturalLanguageTranslator availableLanguageLocaleIDs do: [:id | locales at: id put: (Locale new localeID: id)]. ^locales! ! !Locale class methodsFor: 'private' stamp: 'mir 7/15/2004 16:44'! knownLocales "KnownLocales := nil" ^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! ! !Locale class methodsFor: 'private' stamp: 'ka 2/18/2005 02:40'! migrateSystem "Locale migrateSystem" "Do all the necessary operations to switch to the new Locale environment." LocaleChangeListeners _ nil. self addLocalChangedListener: HandMorph; addLocalChangedListener: Clipboard; addLocalChangedListener: Vocabulary; addLocalChangedListener: PartsBin; addLocalChangedListener: Project; addLocalChangedListener: PaintBoxMorph; yourself! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! addLocalChangedListener: anObjectOrClass self localeChangedListeners add: anObjectOrClass! ! !Locale class methodsFor: 'notification' stamp: 'ka 2/19/2005 02:15'! localeChanged #(PartsBin ParagraphEditor BitEditor FormEditor StandardSystemController ColorPickerMorph) do: [ :key | Smalltalk at: key ifPresent: [ :class | class initialize ]]. Project current localeChanged. self localeChangedListeners do: [:each | each localeChanged]! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! localeChangedListeners ^LocaleChangeListeners ifNil: [LocaleChangeListeners _ OrderedCollection new]! ! !Locale class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 18:07'! initialize "Locale initialize" ! ! !Locale class methodsFor: 'class initialization' stamp: 'nk 8/29/2004 13:21'! initializePlatformEncodings "Locale initializePlatformEncodings" | platform | PlatformEncodings isNil ifTrue: [ PlatformEncodings := Dictionary new ]. platform := PlatformEncodings at: 'default' ifAbsentPut: Dictionary new. platform at: 'default' put: 'iso8859-1'; at: 'Win32 CE' put: 'utf-8'; yourself. platform := PlatformEncodings at: 'ja' ifAbsentPut: Dictionary new. platform at: 'default' put: 'shift-jis'; at: 'unix' put: 'euc-jp'; at: 'Win32 CE' put: 'utf-8'; yourself. platform := PlatformEncodings at: 'ko' ifAbsentPut: Dictionary new. platform at: 'default' put: 'euc-kr'; at: 'Win32 CE' put: 'utf-8'; yourself. platform := PlatformEncodings at: 'zh' ifAbsentPut: Dictionary new. platform at: 'default' put: 'gb2312'; at: 'unix' put: 'euc-cn'; at: 'Win32 CE' put: 'utf-8'; yourself. ! ! !Locale class methodsFor: 'class initialization' stamp: 'nk 8/29/2004 13:20'! platformEncodings PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ]. ^PlatformEncodings ! ! !LocaleID methodsFor: 'initialize' stamp: 'mir 7/15/2004 12:44'! isoLanguage: langString isoCountry: countryStringOrNil isoLanguage := langString. isoCountry := countryStringOrNil! ! !LocaleID methodsFor: 'accessing' stamp: 'nk 8/29/2004 12:42'! displayCountry ^(ISOLanguageDefinition isoCountries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 18:18'! displayLanguage | language | language := (ISOLanguageDefinition iso2LanguageDefinition: self isoLanguage) language. ^self isoCountry ifNil: [language] ifNotNil: [language , ' (' , self displayCountry , ')']! ! !LocaleID methodsFor: 'accessing' stamp: 'dgd 10/7/2004 21:16'! displayName "Answer a proper name to represent the receiver in GUI. The wording is provided by translations of the magic value '<language display name>'. 'English' -> 'English' 'German' -> 'Deutsch' " | magicPhrase translatedMagicPhrase | magicPhrase := '<language display name>'. translatedMagicPhrase := magicPhrase translatedTo: self. ^ translatedMagicPhrase = magicPhrase ifTrue: [self displayLanguage] ifFalse: [translatedMagicPhrase]! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! isoCountry ^isoCountry! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:43'! isoLanguage ^isoLanguage! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/21/2004 19:17'! isoString ^self asString! ! !LocaleID methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:34'! parent ^self class isoLanguage: self isoLanguage! ! !LocaleID methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:37'! translator ^ NaturalLanguageTranslator localeID: self ! ! !LocaleID methodsFor: 'testing' stamp: 'mir 7/15/2004 14:34'! hasParent ^self isoCountry notNil! ! !LocaleID methodsFor: 'printing' stamp: 'mir 7/15/2004 12:45'! printOn: stream "<language>-<country>" stream nextPutAll: self isoLanguage. self isoCountry ifNotNil: [stream nextPut: $-; nextPutAll: self isoCountry]! ! !LocaleID methodsFor: 'printing' stamp: 'tak 11/15/2004 12:45'! storeOn: aStream aStream nextPut: $(. aStream nextPutAll: self class name. aStream nextPutAll: ' isoString: '. aStream nextPutAll: '''' , self printString , ''''. aStream nextPut: $). ! ! !LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! = anotherObject self class == anotherObject class ifFalse: [^false]. ^self isoLanguage = anotherObject isoLanguage and: [self isoCountry = anotherObject isoCountry]! ! !LocaleID methodsFor: 'comparing' stamp: 'mir 7/15/2004 14:23'! hash ^self isoLanguage hash bitXor: self isoCountry hash! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 14:37'! default ^self isoLanguage: 'en'! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 14:35'! isoLanguage: langString ^self isoLanguage: langString isoCountry: nil! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/15/2004 12:46'! isoLanguage: langString isoCountry: countryStringOrNil ^self new isoLanguage: langString isoCountry: countryStringOrNil! ! !LocaleID class methodsFor: 'instance creation' stamp: 'mir 7/21/2004 13:59'! isoString: isoString "Parse the isoString (<language>-<country>) into its components and return the matching LocaleID" "LocaleID isoString: 'en' " "LocaleID isoString: 'en-us' " | parts language country | parts := isoString findTokens: #($- ). language := parts first. parts size > 1 ifTrue: [country := parts second]. ^self isoLanguage: language isoCountry: country! ! !LocaleID class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:09'! current ^Locale current localeID! ! !LoginFailedException methodsFor: 'exceptionDescription' stamp: 'mir 2/15/2002 13:10'! isResumable "Resumable so we can give the user another chance to login" ^true! ! !LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0! Exception for signaling login failures of protocol clients. ! !LongTestCase class methodsFor: 'accessing' stamp: 'md 12/5/2004 21:36'! allTestSelectors DoNotRunLongTestCases ifFalse: [ ^super testSelectors]. ^#().! ! !LongTestCase class methodsFor: 'accessing' stamp: 'sd 9/25/2004 12:57'! doNotRunLongTestCases DoNotRunLongTestCases := true.! ! !LongTestCase class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:31'! runLongTestCases DoNotRunLongTestCases := false.! ! !LongTestCase class methodsFor: 'class initialization' stamp: 'sd 9/25/2004 12:57'! initialize self doNotRunLongTestCases! ! !LongTestCase class methodsFor: 'instance creation' stamp: 'md 12/5/2004 21:34'! buildSuite | suite | suite _ TestSuite new. DoNotRunLongTestCases ifFalse: [ self addToSuiteFromSelectors: suite]. ^suite! ! !LongTestCase class methodsFor: 'testing' stamp: 'md 11/14/2004 21:34'! isAbstract "Override to true if a TestCase subclass is Abstract and should not have TestCase instances built from it" ^self sunitName = #LongTestCase ! ! !LongTestCaseTest methodsFor: 'testing' stamp: 'sd 9/25/2004 14:12'! testLongTestCaseDoNotRun "self debug: #testLongTestCaseDoNotRun" "self run: #testLongTestCaseDoNotRun" LongTestCase doNotRunLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self deny: LongTestCaseTestUnderTest hasRun. ! ! !LongTestCaseTest methodsFor: 'testing' stamp: 'md 12/5/2004 21:28'! testLongTestCaseRun "self debug: #testLongTestCaseRun" "self run: #testLongTestCaseRun" LongTestCase runLongTestCases. LongTestCaseTestUnderTest markAsNotRun. self deny: LongTestCaseTestUnderTest hasRun. LongTestCaseTestUnderTest suite run. self assert: LongTestCaseTestUnderTest hasRun. LongTestCase doNotRunLongTestCases. ! ! !LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'! testWhenRunMarkTestedToTrue RunStatus := true.! ! !LongTestCaseTestUnderTest class methodsFor: 'Accessing' stamp: 'sd 9/25/2004 14:02'! hasRun ^ RunStatus! ! !LongTestCaseTestUnderTest class methodsFor: 'Accessing' stamp: 'md 11/14/2004 21:37'! markAsNotRun ^ RunStatus := false! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:04'! canAssign ^ true! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'! name ^ self key isString ifTrue: [self key] ifFalse: [self key printString]! ! !LookupKey methodsFor: 'testing' stamp: 'ar 8/14/2001 22:39'! isVariableBinding "Return true if I represent a literal variable binding" ^true! ! !LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:59'! beBindingOfType: aClass announcing: aBool "Make the receiver a global binding of the given type" | old new | (Smalltalk associationAt: self key) == self ifFalse:[^self error:'Not a global variable binding']. self class == aClass ifTrue:[^self]. old _ self. new _ aClass key: self key value: self value. old become: new. "NOTE: Now self == read-only (e.g., the new binding)" ^self recompileBindingsAnnouncing: aBool! ! !LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'! beReadOnlyBinding "Make the receiver (a global read-write binding) be a read-only binding" ^self beReadOnlyBindingAnnouncing: true! ! !LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'! beReadOnlyBindingAnnouncing: aBool "Make the receiver (a global read-write binding) be a read-only binding" ^self beBindingOfType: ReadOnlyVariableBinding announcing: aBool! ! !LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:50'! beReadWriteBinding "Make the receiver (a global read-only binding) be a read-write binding" ^self beReadWriteBindingAnnouncing: true! ! !LookupKey methodsFor: 'bindings' stamp: 'ar 8/16/2001 11:51'! beReadWriteBindingAnnouncing: aBool "Make the receiver (a global read-write binding) be a read-write binding" ^self beBindingOfType: Association announcing: aBool! ! !LookupKey methodsFor: 'bindings' stamp: 'dvf 8/23/2003 11:50'! recompileBindingsAnnouncing: aBool "Make the receiver (a global read-write binding) be a read-only binding" aBool ifTrue: [Utilities informUserDuring: [:bar | (self systemNavigation allCallsOn: self) do: [:mref | bar value: 'Recompiling ' , mref asStringOrText. mref actualClass recompile: mref methodSymbol]]] ifFalse: [(self systemNavigation allCallsOn: self) do: [:mref | mref actualClass recompile: mref methodSymbol]]! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'zz 3/2/2004 08:18'! samples "For compatibility with SampledSound. Just return my left channel (which is the only channel if I am mono)." ^ leftSamples ! ! !LoopedSampledSound methodsFor: 'file i/o' stamp: 'sd 9/30/2003 13:41'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." | reverseBytes | (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [ ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. "optimization: if I'm not stereo and sampling rates match, just store my buffer" reverseBytes _ bigEndianFlag ~= SmalltalkImage current isBigEndian. reverseBytes ifTrue: [leftSamples reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]]. reverseBytes ifTrue: [leftSamples reverseEndianness]. "restore to original endianness" ! ! !MCPTest methodsFor: 'Testing - geometry' stamp: 'dgd 2/14/2003 10:13'! defaultBounds "the default bounds for morphs" ^ 0 @ 0 corner: 50 @ 40 ! ! !MCPTest methodsFor: 'Testing - geometry' stamp: 'dgd 2/14/2003 10:13'! defaultTop "the default top for morphs" ^ self defaultBounds top ! ! !MCPTest methodsFor: 'Testing - geometry' stamp: 'dgd 2/14/2003 10:15'! testTop "test the #top: messages and its consequences" | morph factor newTop newBounds | morph _ Morph new. "" factor _ 10. newTop _ self defaultTop + factor. newBounds _ self defaultBounds translateBy: 0 @ factor. "" morph top: newTop. "" self assert: morph top = newTop; assert: morph bounds = newBounds! ! !MCPTest methodsFor: 'Testing' stamp: 'gm 2/22/2003 12:58'! testIsMorphicModel "test isMorphicModel" self deny: Object new isMorphicModel. self deny: Morph new isMorphicModel. self assert: MorphicModel new isMorphicModel. ! ! !MCPTest methodsFor: 'Testing' stamp: 'gm 2/16/2003 20:42'! testIsSystemWindow "test isSystemWindow" self deny: Object new isSystemWindow. self assert: SystemWindow new isSystemWindow. self assert: WorldWindow new isSystemWindow.! ! !MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.484 g: 0.613 b: 0.0! ! !MIDIControllerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:37'! initialize "initialize the state of the receiver" | slider | super initialize. "" self listDirection: #topToBottom. self wrapCentering: #center; cellPositioning: #topCenter. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. channel _ 0. controller _ 7. "channel volume" slider _ SimpleSliderMorph new target: self; actionSelector: #newSliderValue:; minVal: 0; maxVal: 127; extent: 128 @ 10. self addMorphBack: slider. self addMorphBack: (StringMorph contents: 'Midi Controller'). self updateLabel! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:50'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'set channel' translated action: #setChannel:. aCustomMenu add: 'set controller' translated action: #setController:. ! ! !MIDIPianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:55'! initialize "initialize the state of the receiver" super initialize. "" SimpleMIDIPort midiIsSupported ifTrue: [midiPort _ SimpleMIDIPort openDefault]. channel _ 1. velocity _ 100! ! !MIDIPianoKeyboardMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:50'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. midiPort ifNil: [aCustomMenu add: 'play via MIDI' translated action: #openMIDIPort] ifNotNil: [ aCustomMenu add: 'play via built in synth' translated action: #closeMIDIPort. aCustomMenu add: 'new MIDI controller' translated action: #makeMIDIController:]. ! ! !MIDIPianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:40'! mouseDownPitch: midiKey event: event noteMorph: noteMorph midiPort ifNil: [^ super mouseDownPitch: midiKey-1 event: event noteMorph: noteMorph]. noteMorph color: playingKeyColor. soundPlaying ifNil: [midiPort ensureOpen] ifNotNil: [self turnOffNote]. self turnOnNote: midiKey + 23. ! ! !MIDIPianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:41'! mouseUpPitch: midiKey event: event noteMorph: noteMorph midiPort ifNil: [ ^ super mouseUpPitch: midiKey event: event noteMorph: noteMorph]. noteMorph color: ((#(0 1 3 5 6 8 10) includes: midiKey \\ 12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). soundPlaying ifNotNil: [self turnOffNote]. ! ! !MIDIScore methodsFor: 'ambient track' stamp: 'md 12/12/2003 16:21'! eventMorphsDo: aBlock "Evaluate aBlock for all morphs related to the ambient events." ambientTrack == nil ifTrue: [^ self]. ambientTrack do: [:evt | evt morph ifNotNilDo: aBlock]. ! ! !MIMEDocument methodsFor: 'accessing' stamp: 'ar 8/23/2001 22:38'! contents "Compatibility with stream protocol" ^self content! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mdr 5/7/2001 11:47'! parts "Return the parts of this message. There is a far more reliable implementation of parts in MailMessage, but for now we are continuing to use this implementation" | parseStream currLine separator msgStream messages | self isMultipart ifFalse: [^ #()]. parseStream _ ReadStream on: self content. currLine _ ''. ['--*' match: currLine] whileFalse: [currLine _ parseStream nextLine]. separator _ currLine copy. msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator. messages _ OrderedCollection new. [parseStream atEnd] whileFalse: [messages add: msgStream upToEnd. msgStream skipThisLine]. ^ messages collect: [:e | MailMessage from: e] ! ! !MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:37'! isPng ^ self mainType = 'image' and: [self subType = 'png']! ! !MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:38'! isPnm ^ self mainType = 'image' and: [self subType = 'pnm']! ! !MIMEDocument class methodsFor: 'initialize-release' stamp: 'st 9/18/2004 23:36'! defaultMIMEdatabase | d | (d _ Dictionary new) at: 'html' put: 'text/html'; at: 'htm' put: 'text/html'; at: 'xml' put: 'text/xml'; at: 'txt' put: 'text/plain'; at: 'c' put: 'text/plain'; at: 'gif' put: 'image/gif'; at: 'jpg' put: 'image/jpeg'; at: 'jpeg' put: 'image/jpeg'; at: 'gif' put: 'image/gif'; at: 'png' put: 'image/png'; at: 'pnm' put: 'image/pnm'; at: 'xbm' put: 'image/x-xbitmap'; at: 'mid' put: 'audio/midi'; at: 'doc' put: 'application/ms-word-document'. ^d! ! !MIMEHeaderValue methodsFor: 'printing' stamp: 'ls 2/10/2001 12:37'! printOn: aStream super printOn: aStream. aStream nextPutAll: ': '. aStream nextPutAll: self asHeaderValue! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'ls 2/10/2001 13:06'! parameterAt: aParameter put: value parameters at: aParameter put: value! ! !MIMEHeaderValue commentStamp: '<historical>' prior: 0! I contain the value portion of a MIME-compatible header. I must be only initialized with the value and not the field name. E.g. in processing Subject: This is the subject the MIMEHeaderValue should be given only 'This is the subject' For traditional non-MIME headers, the complete value returned for mainValue and paramaters returns an empty collection. For MIME headers, both mainValue and parameters are used.! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:19'! forField: aFName fromString: aString "Create a MIMEHeaderValue from aString. How it is parsed depends on whether it is a MIME specific field or a generic header field." (aFName beginsWith: 'content-') ifTrue: [^self fromMIMEHeader: aString] ifFalse: [^self fromTraditionalHeader: aString] ! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 13:21'! fromMIMEHeader: aString "This is the value of a MIME header field and so is parsed to extract the various parts" | parts newValue parms separatorPos parmName parmValue | newValue _ self new. parts _ ReadStream on: (aString findTokens: ';'). newValue mainValue: parts next. parms _ Dictionary new. parts do: [:e | separatorPos _ e findAnySubStr: '=' startingAt: 1. separatorPos <= e size ifTrue: [parmName _ (e copyFrom: 1 to: separatorPos - 1) withBlanksTrimmed asLowercase. parmValue _ (e copyFrom: separatorPos + 1 to: e size) withBlanksTrimmed withoutQuoting. parms at: parmName put: parmValue]]. newValue parameters: parms. ^ newValue ! ! !MIMEHeaderValue class methodsFor: 'instance creation' stamp: 'mdr 4/11/2001 12:02'! fromTraditionalHeader: aString "This is a traditional non-MIME header (like Subject:) and so should be stored whole" | newValue | newValue _ self new. newValue mainValue: aString. newValue parameters: #(). ^newValue. ! ! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:28'! content ^content ifNil:[content _ contentStream contentsOfEntireFile].! ! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'! contentStream ^contentStream ifNil:[super contentStream]! ! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'ar 4/24/2001 16:27'! contentStream: aFileStream contentStream _ aFileStream. content _ nil.! ! !MIMELocalFileDocument commentStamp: '<historical>' prior: 0! For local files, we do not read the entire contents unless we absolutely have to.! !MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'! contentType: aString contentStream: aStream ^(self contentType: aString content: nil) contentStream: aStream! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 12:22'! currentFrameScaled "Answer a Form containing the current frame scaled to my current size." | f | f _ Form extent: self extent depth: 32. frameBuffer ifNil: [^ f fillColor: (Color gray: 0.75)]. self drawScaledOn: ((FormCanvas on: f) copyOffset: self topLeft negated). ^ f! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 11/16/2001 16:40'! extent: aPoint "Overridden to maintain movie aspect ratio." | scale | frameBuffer ifNil: [^ super extent: aPoint]. scale _ (aPoint x / frameBuffer width) max: (aPoint y / frameBuffer height). scale _ scale max: (16 / frameBuffer width). super extent: (frameBuffer extent * scale) rounded. ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 18:57'! fullFileName "answer the receiver's fullFileName" ^ mpegFile isNil ifTrue: [''] ifFalse: [mpegFile fileName]! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 18:52'! fullScreen "answer whatever the receiver is fullScreen Note: comparation with true to make it work with instances created before the introduccion of the variable" ^ fullScreen == true! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/7/2004 18:56'! fullScreen: aBoolean "change the receiver's fullScreen" fullScreen := aBoolean! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:41'! isRunning "answer whatever the receiver is running" ^ running! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'mu 6/25/2003 02:41'! moviePosition "Answer a number between 0.0 and 1.0 indicating the current position within the movie." mpegFile ifNil: [^ 0.0]. mpegFile fileHandle ifNil: [^ 0.0]. (FileStream isAFileNamed: mpegFile fileName) ifFalse: [^0.0]. mpegFile hasVideo ifTrue: [^ ((mpegFile videoGetFrame: 0) asFloat / (mpegFile videoFrames: 0)) min: 1.0]. soundTrack ifNotNil: [^ soundTrack soundPosition]. ^ 0.0 ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 12/16/2001 12:34'! moviePosition: fraction "Jump to the position the given fraction through the movie. The argument is a number between 0.0 and 1.0." | frameCount frameIndex | self mpegFileIsOpen ifFalse: [^ self]. self stopPlaying. mpegFile hasVideo ifTrue: [ frameCount _ mpegFile videoFrames: 0. frameIndex _ (frameCount * fraction) truncated - 1. frameIndex _ (frameIndex max: 0) min: (frameCount - 3). mpegFile videoSetFrame: frameIndex stream: 0. ^ self nextFrame]. mpegFile hasAudio ifTrue: [ soundTrack soundPosition: fraction]. ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 6/3/2001 14:34'! repeat "Answer the repeat flag." repeat ifNil: [repeat _ false]. ^ repeat ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 6/3/2001 14:33'! repeat: aBoolean "Set the repeat flag. If true, the movie will loop back to the beginning when it gets to the end." repeat _ aBoolean. ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:13'! subtitle "answer the subtitle for the current frame" self hasSubtitles ifFalse: [^ '']. self mpegFileIsOpen ifFalse: [^ '']. mpegFile hasVideo ifFalse:[^'']. "" ^ subtitles subtitleForFrame: (mpegFile videoGetFrame: 0)! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:12'! subtitlesFileShortName "answer the receiver's subtitlesFileShortName" | fileFull defaultDirFull fileShort | self hasSubtitles ifFalse:[^ '']. " answer the shortest path to the file to make easier to move morphs with references to files between different platforms" fileFull := subtitles fileName. "" defaultDirFull := FileDirectory default fullName. fileShort := (fileFull beginsWith: defaultDirFull) ifTrue: [fileFull allButFirst: defaultDirFull size + 1] ifFalse: [fileFull]. "" ^ fileShort! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:44'! subtitlesFileShortName: aString "change the receiver's subtitlesFileShortName, that means open the subtitles file named aString" | fullName | self mpegFileIsOpen ifFalse: [^ self]. mpegFile hasVideo ifFalse: [^ self]. "" fullName := FileDirectory default fullNameFor: aString. self openSubtitlesFileNamed: fullName! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:40'! totalFrames "Answer the total number of frames in this movie." mpegFile ifNil: [^ 0]. mpegFile fileHandle ifNil: [^ 0]. (FileStream isAFileNamed: mpegFile fileName) ifFalse: [^ 0]. mpegFile hasVideo ifFalse: [^ 0]. ^ mpegFile videoFrames: 0! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:40'! totalSeconds "Answer the total number of seconds in this movie." mpegFile ifNil: [^ 0]. mpegFile fileHandle ifNil: [^ 0]. (FileStream isAFileNamed: mpegFile fileName) ifFalse: [^ 0]. mpegFile hasVideo ifFalse: [^ 0]. ^ self totalFrames asFloat / (mpegFile videoFrameRate: 0)! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 21:47'! videoFileShortName "answer the receiver's videoFileShortName" | fileFull defaultDirFull fileShort | mpegFile isNil ifTrue: [^ '']. " answer the shortest path to the file to make easier to move morphs with references to files between different platforms" fileFull := mpegFile fileName. "" defaultDirFull := FileDirectory default fullName. fileShort := (fileFull beginsWith: defaultDirFull) ifTrue: [fileFull allButFirst: defaultDirFull size + 1] ifFalse: [fileFull]. "" ^ fileShort! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:45'! videoFileShortName: aString "change the receiver's videoFileShortName, that means open the video file named aString" | fullName | self stopPlaying. fullName := FileDirectory default fullNameFor: aString. self openFileNamed: fullName! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jm 6/3/2001 14:35'! volume "Answer the sound playback volume." ^ volume ! ! !MPEGDisplayMorph methodsFor: 'accessing' stamp: 'jdl 3/28/2003 09:41'! volume: aNumber "Set the sound playback volume to the given level, between 0.0 and 1.0." volume := aNumber asFloat. volume := volume max: 0.0. volume := volume min: 1.0. soundTrack ifNotNil: [soundTrack volume: volume]! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 11/16/2001 15:39'! nextFrame "Fetch the next frame into the frame buffer." mpegFile ifNil: [^ self]. mpegFile videoReadFrameInto: frameBuffer stream: 0. self changed. ! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 10/11/2004 23:06'! playUntilPosition: finalPosition "Play the movie until the given position, then stop." | totalFrames | totalFrames _ self totalFrames. (totalFrames > 0 and: [finalPosition > 0]) ifFalse: [^ self]. "do nothing" self startPlaying. stopFrame _ (finalPosition * totalFrames) asInteger min: totalFrames! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 4/6/2001 08:31'! previousFrame "Go to the previous frame." | n | mpegFile ifNil: [^ self]. running ifTrue: [^ self]. n _ (mpegFile videoGetFrame: 0) - 2. n _ (n min: ((mpegFile videoFrames: 0) - 3)) max: 0. mpegFile videoSetFrame: n stream: 0. self nextFrame. ! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 11/13/2001 07:36'! rewindMovie "Rewind to the beginning of the movie." "Details: Seeking by percent or frame number both seem to have problems, so just re-open the file." | savedExtent savedRate | self mpegFileIsOpen ifFalse: [^ self]. self stopPlaying. "re-open the movie, retaining current extent and frame rate" savedExtent _ self extent. savedRate _ desiredFrameRate. self openFileNamed: mpegFile fileName. "recomputes rate and extent" self extent: savedExtent. desiredFrameRate _ savedRate. ! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'dgd 10/8/2003 19:10'! setFrameRate "Ask the user to specify the desired frame rate." | rateString | rateString := FillInTheBlank request: 'Desired frames per second?' translated initialAnswer: desiredFrameRate printString. rateString isEmpty ifTrue: [^self]. desiredFrameRate := rateString asNumber asFloat. desiredFrameRate := desiredFrameRate max: 0.1! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 10/10/2004 23:58'! startPlaying "Start playing the movie at the current position." | frameIndex | self stopPlaying. stopFrame _ nil. self mpegFileIsOpen ifFalse: [^ self]. (FileStream isAFileNamed: mpegFile fileName) ifFalse: [ | newFileResult newFileName | self inform: 'Path changed. Enter new one for: ', (FileDirectory localNameFor: mpegFile fileName). newFileResult _ StandardFileMenu oldFile. newFileName _ newFileResult directory fullNameFor: newFileResult name. mpegFile openFile: newFileName]. mpegFile hasAudio ifTrue: [mpegFile hasVideo ifTrue: ["set movie frame position from soundTrack position" soundTrack reset. "ensure file is open before positioning" soundTrack soundPosition: (mpegFile videoGetFrame: 0) asFloat / (mpegFile videoFrames: 0). "now set frame index from the soundtrack position for best sync" frameIndex _ ((soundTrack millisecondsSinceStart * desiredFrameRate) // 1000). frameIndex _ (frameIndex max: 0) min: ((mpegFile videoFrames: 0) - 3). mpegFile videoSetFrame: frameIndex stream: 0]. SoundPlayer stopReverb. soundTrack volume: volume. soundTrack repeat: repeat. soundTrack resumePlaying. startFrame _ startMSecs _ 0] ifFalse: [soundTrack _ nil. startFrame _ mpegFile videoGetFrame: 0. startMSecs _ Time millisecondClockValue]. running _ true! ! !MPEGDisplayMorph methodsFor: 'commands' stamp: 'jm 6/3/2001 14:30'! stopPlaying "Stop playing the movie." running _ false. soundTrack ifNotNil: [soundTrack pause]. ! ! !MPEGDisplayMorph methodsFor: 'drawing' stamp: 'jm 3/20/2001 15:57'! areasRemainingToFill: aRectangle "Drawing optimization. Since I completely fill my bounds with opaque pixels, this method tells Morphic that it isn't necessary to draw any morphs covered by me." ^ aRectangle areasOutside: self bounds ! ! !MPEGDisplayMorph methodsFor: 'drawing' stamp: 'jm 11/11/2001 15:49'! drawOn: aCanvas "Draw the current frame image, if there is one. Otherwise, fill screen with gray." frameBuffer ifNil: [aCanvas fillRectangle: self bounds color: (Color gray: 0.75)] ifNotNil: [ self extent = frameBuffer extent ifTrue: [aCanvas drawImage: frameBuffer at: bounds origin] ifFalse: [self drawScaledOn: aCanvas]]. ! ! !MPEGDisplayMorph methodsFor: 'drawing' stamp: 'jm 11/13/2001 08:45'! drawScaledOn: aCanvas "Draw the current frame image scaled to my bounds." | outForm destPoint warpBlt | ((aCanvas isKindOf: FormCanvas) and: [aCanvas form = Display]) ifTrue: [ "optimization: when canvas is the Display, Warpblt directly to it" outForm _ Display. destPoint _ bounds origin + aCanvas origin] ifFalse: [ outForm _ Form extent: self extent depth: aCanvas form depth. destPoint _ 0@0]. warpBlt _ (WarpBlt current toForm: outForm) sourceForm: frameBuffer; colorMap: (frameBuffer colormapIfNeededForDepth: outForm depth); cellSize: 1; "installs a new colormap if cellSize > 1" combinationRule: Form over. outForm == Display ifTrue: [warpBlt clipRect: aCanvas clipRect]. warpBlt copyQuad: frameBuffer boundingBox innerCorners toRect: (destPoint extent: self extent). outForm == Display ifFalse: [ aCanvas drawImage: outForm at: bounds origin]. ! ! !MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 20:06'! handlesKeyboard: evt ^ true! ! !MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 23:02'! handlesMouseDown: evt ^ evt yellowButtonPressed! ! !MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:37'! keyStroke: evt | char asc | char := evt keyCharacter. asc := char asciiValue. (char = $o or:[ char = $O]) ifTrue: ["open o/O" self openMPEGFile. ^self]. (char = $m or:[ char = $M]) ifTrue: ["menu key m/M" self invokeMenu. ^self]. (char = $r or:[ char = $R]) ifTrue: ["rewind r/R" self rewindMovie. ^self]. (char = $p or:[ char = $P]) ifTrue: ["play p/P" self startPlaying. ^self]. (char = $s or:[ char = $S]) ifTrue: ["stop s/S" self stopPlaying. ^self]. (asc = 28) ifTrue: [ "left arrow key" self previousFrame. ^self]. (asc = 29) ifTrue: [ "right arrow key" self nextFrame. ^self]. (char = $u or:[ char = $U]) ifTrue: ["subtitles file u/U" self openSubtitlesFile. ^self].! ! !MPEGDisplayMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:13'! mouseDown: evt evt yellowButtonPressed ifTrue: [^ self invokeMenu]. super mouseDown: evt! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 22:09'! closeFile "Close my MPEG file, if any." mpegFile isNil ifFalse: [ mpegFile closeFile. mpegFile := nil. frameBuffer := nil]. subtitles := nil. self changed. ! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'jm 3/22/2001 12:42'! mpegFileIsOpen "Answer true if I have an open, valid MPEG file handle. If the handle is not valid, try to re-open the file." mpegFile ifNil: [^ false]. mpegFile fileHandle ifNil: [ "try to reopen the file, which may have been saved in a snapshot" mpegFile openFile: mpegFile fileName. mpegFile fileHandle ifNil: [mpegFile _ nil]]. ^ mpegFile notNil ! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/7/2004 19:07'! openFileNamed: mpegFileName "Try to open the MPEG file with the given name. Answer true if successful." | e | self closeFile. (FileDirectory default fileExists: mpegFileName) ifFalse: [self inform: ('File not found: {1}' translated format: {mpegFileName}). ^ false]. (MPEGFile isFileValidMPEG: mpegFileName) ifTrue: [mpegFile := MPEGFile openFile: mpegFileName] ifFalse: [ (JPEGMovieFile isJPEGMovieFile: mpegFileName) ifTrue: [mpegFile := JPEGMovieFile new openFileNamed: mpegFileName] ifFalse: [self inform: ('Not an MPEG or JPEG movie file: {1}' translated format: {mpegFileName}). ^ false]]. mpegFile fileHandle ifNil: [^ false]. "initialize soundTrack" mpegFile hasAudio ifTrue: [soundTrack := mpegFile audioPlayerForChannel: 1] ifFalse: [soundTrack := nil]. mpegFile hasVideo ifTrue: [ "set screen size and display first frame" desiredFrameRate := mpegFile videoFrameRate: 0. soundTrack ifNotNil: [ "compute frame rate from length of audio track" desiredFrameRate := (mpegFile videoFrames: 0) / soundTrack duration]. e := (mpegFile videoFrameWidth: 0)@(mpegFile videoFrameHeight: 0). frameBuffer := Form extent: e depth: (Display depth max: 16). super extent: e. self nextFrame] ifFalse: [ "hide screen for audio-only files" super extent: 250@0]. ! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'jm 11/26/2001 08:26'! openMPEGFile "Invoked by the 'Open' button. Prompt for a file name and try to open that file as an MPEG file." | result | result _ (FileList2 modalFileSelectorForSuffixes: #('mp3' 'mpg' 'mpeg' 'jmv')) . result ifNil: [^ self]. self stopPlaying. self openFileNamed: (result fullName). ! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 20:16'! openSubtitlesFile "Invoked by the 'Subtitles' button. Prompt for a file name and try to open that file as a subs file." | result | self mpegFileIsOpen ifFalse: [^ self]. mpegFile hasVideo ifFalse: [self inform: 'select a video file' translated. ^ self]. result := FileList2 modalFileSelectorForSuffixes: #('sub' ). result ifNil: [^ self]. self openSubtitlesFileNamed: result fullName! ! !MPEGDisplayMorph methodsFor: 'file open/close' stamp: 'dgd 3/8/2004 22:58'! openSubtitlesFileNamed: aString "Try to open the subtitle file with the given name. Answer true if successful." subtitles := nil. "" "try to create the displayer. it's useful for instances of mpegplayer older than the subtitles support" self subtitlesDisplayer. "" (FileDirectory default fileExists: aString) ifFalse: [self inform: ('File not found: {1}' translated format: {aString}). ^ false]. Utilities informUser: 'opening the file, please wait' translated during: [subtitles := MPEGSubtitles fromFileNamed: aString]! ! !MPEGDisplayMorph methodsFor: 'initialization' stamp: 'dgd 3/8/2004 23:05'! initialize "initialize the state of the receiver" super initialize."" super extent: 250 @ 0. frameBuffer := nil. mpegFile := nil. running := false. desiredFrameRate := 10.0. allowFrameDropping := true. repeat := false. soundTrack := nil. volume := 0.5. fullScreen := false. "" self initializeSubtitlesDisplayer! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'jm 12/14/2001 15:34'! addSoundtrack "Add a soundtrack to this JPEG movie." | result soundFileName menu compression | (mpegFile isKindOf: JPEGMovieFile) ifFalse: [^ self]. "do nothing if not a JPEG movie" result _ StandardFileMenu oldFile. result ifNil: [^ self]. soundFileName _ result directory pathName, FileDirectory slash, result name. menu _ CustomMenu new title: 'Compression type:'. menu addList: #( ('none (353 kbps)' none) ('mulaw (176 kbps)' mulaw) ('adpcm5 (110 kbps)' adpcm5) ('adpcm4 (88 kbps)' adpcm4) ('adpcm3 (66 kbps)' adpcm3) ('gsm (36 kbps)' gsm)). compression _ menu startUp. compression ifNil: [^ self]. mpegFile closeFile. JPEGMovieFile addSoundtrack: soundFileName toJPEGMovieNamed: mpegFile fileName compressionType: compression. self openFileNamed: mpegFile fileName. ! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:10'! createJPEGfromFolderOfFrames "Create a new JPEG movie file from an folder of individual frames. Prompt the user for the folder and file names and the quality setting, then do the conversion." | result folderName jpegFileName q frameRate | result := StandardFileMenu oldFile. result ifNil: [^self]. folderName := result directory pathName. jpegFileName := FillInTheBlank request: 'New movie name?' translated. jpegFileName isEmpty ifTrue: [^self]. (jpegFileName asLowercase endsWith: '.jmv') ifFalse: [jpegFileName := jpegFileName , '.jmv']. result := FillInTheBlank request: 'Quality level (1 to 100)?' translated. q := result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100]. result := FillInTheBlank request: 'Frame rate?' translated. frameRate := result ifNil: [10] ifNotNil: [(result asNumber rounded max: 1) min: 100]. JPEGMovieFile convertFromFolderOfFramesNamed: folderName toJPEGMovieNamed: jpegFileName frameRate: frameRate quality: q! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:04'! createJPEGfromMPEG "Create a new JPEG movie file from an MPEG movie. Prompt the user for the file names and the quality setting, then do the conversion." | result mpegFileName jpegFileName q | result := StandardFileMenu oldFile. result ifNil: [^self]. mpegFileName := result directory pathName , FileDirectory slash , result name. jpegFileName := FillInTheBlank request: 'New movie name?' translated. jpegFileName isEmpty ifTrue: [^self]. (jpegFileName asLowercase endsWith: '.jmv') ifFalse: [jpegFileName := jpegFileName , '.jmv']. result := FillInTheBlank request: 'Quality level (1 to 100)?' translated. q := result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100]. JPEGMovieFile convertMPEGFileNamed: mpegFileName toJPEGMovieNamed: jpegFileName quality: q! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'yo 2/20/2005 20:05'! createJPEGfromSqueakMovie "Create a new JPEG movie file from an SqueakTime movie. Prompt the user for the file names and the quality setting, then do the conversion." | result squeakMovieFileName jpegFileName q | result := StandardFileMenu oldFile. result ifNil: [^self]. squeakMovieFileName := result directory pathName , FileDirectory slash , result name. jpegFileName := FillInTheBlank request: 'New movie name?' translated. jpegFileName isEmpty ifTrue: [^self]. (jpegFileName asLowercase endsWith: '.jmv') ifFalse: [jpegFileName := jpegFileName , '.jmv']. result := FillInTheBlank request: 'Quality level (1 to 100)?' translated. q := result ifNil: [50] ifNotNil: [(result asNumber rounded max: 1) min: 100]. JPEGMovieFile convertSqueakMovieNamed: squeakMovieFileName toJPEGMovieNamed: jpegFileName quality: q! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'! doubleSize "change the receiver's extent to double of the normal size" self magnifyBy: 2! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'! halfSize "change the receiver's extent to a half of the normal size" self magnifyBy: 1 / 2! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 21:05'! invokeMenu "Invoke a menu of additonal functions." | aMenu | aMenu := MenuMorph new. aMenu defaultTarget: self. aMenu addList: { {'open file (o)' translated. #openMPEGFile}. #-. {'rewind (r)' translated. #rewindMovie}. {'play (p)' translated. #startPlaying}. {'stop (s)' translated. #stopPlaying}. {'previous frame (<-)' translated. #previousFrame}. {'next frame (->)' translated. #nextFrame}. #-. }. aMenu addLine. aMenu add: 'zoom' translated subMenu: self zoomSubMenu. aMenu add: 'subtitles' translated subMenu: self subtitlesSubMenu. aMenu add: 'advanced' translated subMenu: self advancedSubMenu. aMenu popUpEvent: self world activeHand lastEvent in: self world ! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 13:34'! normalSize "change the receiver's extent to the normal size" self magnifyBy: 1! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'jm 12/13/2001 20:48'! removeAllSoundtracks "Remove all soundtracks from this JPEG movie." (mpegFile isKindOf: JPEGMovieFile) ifFalse: [^ self]. "do nothing if not a JPEG movie" mpegFile closeFile. JPEGMovieFile removeSoundtrackFromJPEGMovieNamed: mpegFile fileName. self openFileNamed: mpegFile fileName. ! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'! setSubtitlesBackgroundColor "open a dialog to change the background color of the subtitles" self subtitlesDisplayer openAPropertySheet! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'! setSubtitlesColor "open a dialog to change the color of the subtitles" self subtitlesDisplayer changeSubtitlesColor! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 22:57'! setSubtitlesFont "change the subtitles font" self subtitlesDisplayer changeFont! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'dgd 3/8/2004 14:13'! toggleFullScreen "Toggle the fullScreen flag." mpegFile isNil ifTrue: [^ self]. mpegFile hasVideo ifFalse: [^ self]. "" self fullScreen: self fullScreen not. "" "set screen size" self fullScreen ifTrue: ["" self extent: Display extent. World activeHand newMouseFocus: self. self comeToFront] ifFalse: [self extent: self normalExtent]. "" (self fullScreen and: [self owner isKindOf: MPEGMoviePlayerMorph]) ifTrue: [self owner position: -6 @ -6] ifFalse: [self owner == self world ifFalse: [self owner position: 0 @ 0] ifTrue:[self position:0@0]]. "" self nextFrame! ! !MPEGDisplayMorph methodsFor: 'menu' stamp: 'jm 12/13/2001 08:55'! toggleRepeat "Toggle the repeat flag." repeat _ repeat not. ! ! !MPEGDisplayMorph methodsFor: 'other' stamp: 'jm 10/11/2004 00:20'! advanceFrame "Advance to the next frame if it is time to do so, skipping frames if necessary." | msecs currentFrame desiredFrame framesToAdvance | mpegFile hasVideo ifFalse: [^ self]. soundTrack ifNil: [msecs _ Time millisecondClockValue - startMSecs] ifNotNil: [msecs _ soundTrack millisecondsSinceStart - SoundPlayer bufferMSecs]. desiredFrame _ startFrame + ((msecs * desiredFrameRate) // 1000) + 1. desiredFrame _ desiredFrame min: (mpegFile videoFrames: 0). currentFrame _ mpegFile videoGetFrame: 0. stopFrame ifNotNil: [desiredFrame _ desiredFrame min: stopFrame. currentFrame >= stopFrame ifTrue: [^ self stopPlaying]]. framesToAdvance _ desiredFrame - currentFrame. framesToAdvance <= 0 ifTrue: [^ self]. (allowFrameDropping and: [framesToAdvance > 1]) ifTrue: [mpegFile videoDropFrames: framesToAdvance - 1 stream: 0]. self nextFrame! ! !MPEGDisplayMorph methodsFor: 'other' stamp: 'jm 11/14/2001 11:58'! jpegMovieSize: quality "Convert all my frames to a JPEG and measure the total size." | jpegSize jpegDecodeTime jpegStream t outForm | mpegFile hasVideo ifFalse: [^ self error: 'movie has no video']. jpegSize _ 0. jpegDecodeTime _ 0. jpegStream _ WriteStream on: (ByteArray new: 100000). self rewindMovie. [(mpegFile videoGetFrame: 0) < (mpegFile videoFrames: 0)] whileTrue: [ jpegStream reset. (JPEGReadWriter2 on: jpegStream) nextPutImage: frameBuffer quality: quality progressiveJPEG: false. jpegSize _ jpegSize + jpegStream position. t _ [ outForm _ (JPEGReadWriter2 on: (ReadStream on: jpegStream contents)) nextImage ] timeToRun. jpegDecodeTime _ jpegDecodeTime + t. outForm display. frameBuffer displayAt: (outForm width + 10)@0. self nextFrame]. ^ Array with: jpegSize with: jpegDecodeTime with: (mpegFile videoFrames: 0) ! ! !MPEGDisplayMorph methodsFor: 'other' stamp: 'jm 11/21/2001 16:58'! measureMaxFrameRate "For testing. Play through the movie as fast as possible, updating the world each time, and report the frame rate." | oldFrameRate oldFrameDropping t | self rewindMovie. oldFrameRate _ desiredFrameRate. oldFrameDropping _ allowFrameDropping. desiredFrameRate _ 1000.0. allowFrameDropping _ false. self startPlaying. t _ [[running] whileTrue: [self world doOneCycleNow]] timeToRun. desiredFrameRate _ oldFrameRate. allowFrameDropping _ oldFrameDropping. ^ (mpegFile videoFrames: 0) / (t / 1000.0) ! ! !MPEGDisplayMorph methodsFor: 'stepping' stamp: 'jm 6/3/2001 18:38'! step "If I'm running and the mpegFile is open and has video, advance to the next frame. Stop if we we hit the end of the video." running ifFalse: [^ self]. mpegFile ifNil: [^ self]. (mpegFile hasVideo and: [(mpegFile videoGetFrame: 0) >= (mpegFile videoFrames: 0)]) ifTrue: [ "end of video" self stopPlaying. repeat ifTrue: [ self rewindMovie. self startPlaying]] ifFalse: [self advanceFrame]. ! ! !MPEGDisplayMorph methodsFor: 'stepping' stamp: 'jm 4/6/2001 08:47'! stepTime "Run my step method as often as possible. Step does very little work if it is not time to advance to the next frame." ^ 0 ! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 12:46'! advancedSubMenu "private - create the advanced submenu" | subMenu | subMenu := MenuMorph new. subMenu defaultTarget: self. repeat ifTrue: [subMenu add: 'turn off repeat (now on)' translated action: #toggleRepeat] ifFalse: [subMenu add: 'turn on repeat (now off)' translated action: #toggleRepeat]. subMenu addLine. subMenu addList: { {'set frame rate' translated. #setFrameRate}. #-. {'create JPEG movie from MPEG' translated. #createJPEGfromMPEG}. {'create JPEG movie from SqueakMovie' translated. #createJPEGfromSqueakMovie}. {'create JPEG movie from folder of frames' translated. #createJPEGfromFolderOfFrames} }. (mpegFile isKindOf: JPEGMovieFile) ifTrue: [ subMenu addLine. mpegFile hasAudio ifTrue: [subMenu add: 'remove all soundtracks' translated action: #removeAllSoundtracks] ifFalse: [subMenu add: 'add soundtrack' translated action: #addSoundtrack]]. ^ subMenu ! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:11'! hasSubtitles "answer if the receiver has subtitles or not" ^ mpegFile isNil not and: [subtitles isNil not]! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 23:03'! initializeSubtitlesDisplayer "private - builds the subtitle displayer" subtitlesDisplayer := MPEGSubtitlesDisplayer on: self selector: #subtitle. subtitlesDisplayer contents:''. self addMorphFront: subtitlesDisplayer. ^ subtitlesDisplayer! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 14:12'! magnifyBy: aNumber "private - scale the video (if any) to a scale of the normalExtent" | ne | fullScreen := false."" ne := self normalExtent. ne isNil ifFalse: [self extent: (ne * aNumber) rounded]! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 13:30'! normalExtent "private - answer the extent of the video, if any" (mpegFile isNil or: [mpegFile hasVideo not]) ifTrue: [^ nil]. "" ^ (mpegFile videoFrameWidth: 0) @ (mpegFile videoFrameHeight: 0)! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:59'! subtitlesDisplayer "private - answer the receiver's subtitlesDisplayer. create one if needed" ^ subtitlesDisplayer ifNil: [self initializeSubtitlesDisplayer]! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 22:22'! subtitlesSubMenu "private - create the subtitles submenu" | subMenu | subMenu := MenuMorph new. subMenu defaultTarget: self. subMenu add: 'open subtitles file (u)' translated action: #openSubtitlesFile. self hasSubtitles ifTrue: [ subMenu addLine. subMenu add: 'set subtitles font' translated action: #setSubtitlesFont. subMenu add: 'set subtitles color' translated action: #setSubtitlesColor. subMenu add: 'set subtitles background color' translated action: #setSubtitlesBackgroundColor]. ^ subMenu ! ! !MPEGDisplayMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 21:08'! zoomSubMenu "private - create the zoom submenu" | subMenu | subMenu := MenuMorph new. subMenu defaultTarget: self. self fullScreen ifTrue: [subMenu add: 'turn off full screen' translated action: #toggleFullScreen] ifFalse: [subMenu add: 'turn on full screen' translated action: #toggleFullScreen]. subMenu addLine. subMenu add: '50%' action: #halfSize. subMenu add: '100%' action: #normalSize. subMenu add: '200%' action: #doubleSize. ^ subMenu ! ! !MPEGDisplayMorph commentStamp: '<historical>' prior: 0! I am a simple display screen for an MPEG movie player. My step method advances the movie according to the current frame rate. If necessary, frames as skipped to maintain the desired frame rate. However, since even skipping frames takes time, it may not be possible to achieve fast frame rates with large frame sizes on slow machines. ! !MPEGFile methodsFor: 'access' stamp: 'yo 7/2/2004 15:58'! endianness ^endianness isNil ifTrue: [endianness _ SmalltalkImage current endianness] ifFalse: [endianness]! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 19:04'! fileHandle (Smalltalk externalObjects at: fileIndex ifAbsent: [^nil]) == fileBits ifTrue: [^fileBits] ifFalse: [^nil]. ! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/18/2000 18:38'! fileName ^pathToFile! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:54'! getPercentage "Return current location by percentage, 0.0-1.0" ^self primGetPercentage: self fileHandle ! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/29/2000 19:28'! getTOC: timecode doStreams: streams | buffer | buffer _ String new: 64*1024+1. self primGenerateToc: self fileHandle useSearch: timecode doStreams: streams buffer: buffer. ^buffer! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:56'! getTimeCode "Return time code, (float) " ^self primGetTime: self fileHandle! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:53'! seekPercentage: aFloat self primSeekPercentage: self fileHandle percentage: aFloat asFloat ! ! !MPEGFile methodsFor: 'access' stamp: 'JMM 9/20/2000 01:56'! setMMX: aValue " true is set, false is off. May not be supported " self primSetMMX: self fileHandle useMMX: aValue ! ! !MPEGFile methodsFor: 'audio' stamp: 'jm 11/17/2001 08:18'! audioChannels: aStream "Returns -1 if error, otherwise returns audioChannels for stream aStream" self hasAudio ifFalse: [^ 0]. ^[self primAudioChannels: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioGetSample: aStream "Returns number of current sample, or -1 if error" self hasAudio ifFalse: [^-1]. ^[(self primGetSample: self fileHandle stream: aStream) asInteger] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'audio' stamp: 'jm 11/17/2001 09:36'! audioPlayerForChannel: channelNumber "Answer a streaming sound for playing the audio channel with the given index." "Note: The MP3 player can not yet isolate a single channel from a multi-channel audio stream." ^ StreamingMP3Sound new initMPEGFile: self streamIndex: 0 ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber "Used to read other channels after first ReadBuffer Returns -1 if error, otherwise 0" self hasAudio ifFalse: [^-1]. ^[self audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: (aBuffer size * aBuffer bytesPerElement // 2)] on: Error do: [-1]! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioReReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: aSampleNumber "Used to read other channels after first ReadBuffer Returns -1 if error, otherwise 0 Note this call requires passing in the samples to read, ensure you get the number right" self hasAudio ifFalse: [^-1]. ^[self primAudioReReadBuffer: self fileHandle buffer: aBuffer channel: aChannelNumber samples: aSampleNumber stream: aStreamNumber] on: Error do: [-1]! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber "Returns -1 if error, otherwise 0" self hasAudio ifFalse: [^-1]. ^[self audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: (aBuffer size* aBuffer bytesPerElement)//2] on: Error do: [-1]! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioReadBuffer: aBuffer stream: aStreamNumber channel: aChannelNumber samples: aSampleNumber "Returns -1 if error, otherwise 0 Note this call requires passing in the samples to read, ensure you get the number right" self hasAudio ifFalse: [^-1]. ^[self primAudioReadBuffer: self fileHandle buffer: aBuffer channel: aChannelNumber samples: aSampleNumber stream: aStreamNumber] on: Error do: [-1]! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioSampleRate: aStream "Returns sample rate, or -1 if error" self hasAudio ifFalse: [^-1]. ^[self primSampleRate: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioSamples: aStream "Returns -1 if error, otherwise returns audioSamples for stream aStream" self hasAudio ifFalse: [^-1]. ^[(self primAudioSamples: self fileHandle stream: aStream) asInteger] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 11/21/2000 13:13'! audioSetSample: aNumber stream: aStream "Set number of targeted sample, returns 0 if ok, -1 if failure" self hasAudio ifFalse: [^-1]. ^[self primSetSample: self fileHandle sample: aNumber asFloat stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:57'! endOfAudio: aStream "Returns true if end of Audio" self hasAudio ifFalse: [^true]. ^self primEndOfAudio: self fileHandle stream: aStream ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:56'! hasAudio "Returns true if file has audio" ^self primHasAudio: self fileHandle ! ! !MPEGFile methodsFor: 'audio' stamp: 'JMM 9/20/2000 01:53'! totalAudioStreams "Returns total number of audio streams" ^self primTotalAudioStreams: self fileHandle ! ! !MPEGFile methodsFor: 'converting' stamp: 'dgd 2/16/2004 14:19'! convertToSqueakMovieFileNamed: fileName "convert the receiver to a squeak-format movie" " (MPEGFile openFile: '/H/squeak/Small-Land/Demo/media/mazinger_z_spanish_op.mpg') convertToSqueakMovieFileNamed: 'MazingerZ.squeakmovie' " | movieFile max w h d frameBuffer | movieFile := FileStream newFileNamed: fileName. [movieFile binary. "no idea what goes here..." movieFile nextInt32Put: 0. movieFile nextInt32Put: (w := self videoFrameWidth: 0). movieFile nextInt32Put: (h := self videoFrameHeight: 0). "Depth of form data stored" "we really don't know but try to preserve some space" movieFile nextInt32Put: (d := 16). movieFile nextInt32Put: (max := self videoFrames: 0). "min: 100" movieFile nextInt32Put: (1000 * 1000 / (self videoFrameRate: 0)) rounded. "Padding?" movieFile nextPutAll: (ByteArray new: 128 - movieFile position). frameBuffer := Form extent: w @ h depth: d. self videoSetFrame: 1 stream: 0. 'Converting movie...' displayProgressAt: Sensor cursorPoint from: 1 to: max during: [:bar | 1 to: max do: [:i | bar value: i. self videoReadFrameInto: frameBuffer stream: 0. frameBuffer display. movieFile nextInt32Put: i. movieFile nextPutAll: frameBuffer bits]]] ensure: [movieFile close]! ! !MPEGFile methodsFor: 'file ops' stamp: 'JMM 9/20/2000 02:05'! finalize self fileHandle notNil ifTrue: [self primFileClose: self fileHandle]. self fileHandle = fileBits ifTrue: [Smalltalk unregisterExternalObject: fileIndex]. fileBits _ nil. fileIndex _ 0.! ! !MPEGFile methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 01:59'! closeFile self finalize.! ! !MPEGFile methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 01:57'! openFile: aPath pathToFile _ aPath. fileBits _ self primFileOpen: aPath. fileBits notNil ifTrue: [fileIndex _ Smalltalk registerExternalObject: fileBits. self register.] ! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:19'! primAudioChannels: aHandle stream: aStream <primitive: 'primitiveMPEG3AudioChannels' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:35'! primAudioReReadBuffer: aFileHandle buffer: aBuffer channel: aChannel samples: aSampleNumber stream: aStreamNumber <primitive: 'primitiveMPEG3ReReadAudio' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:31'! primAudioReadBuffer: aFileHandle buffer: aBuffer channel: aChannel samples: aSampleNumber stream: aStreamNumber <primitive: 'primitiveMPEG3ReadAudio' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:23'! primAudioSamples: aHandle stream: aStream <primitive: 'primitiveMPEG3AudioSamples' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 17:54'! primDropFrame: aHandle frame: aNumberOfFrames stream: aStream <primitive: 'primitiveMPEG3DropFrames' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:50'! primEndOfAudio: aHandle stream: aStream <primitive: 'primitiveMPEG3EndOfAudio' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:51'! primEndOfVideo: aHandle stream: aStream <primitive: 'primitiveMPEG3EndOfVideo' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 13:58'! primFileClose: aHandle "Close the file" <primitive: 'primitiveMPEG3Close' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 03:56'! primFileOpen: aPath "Open the file" <primitive: 'primitiveMPEG3Open' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:52'! primFrameRate: aHandle stream: aStream <primitive: 'primitiveMPEG3FrameRate' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/29/2000 17:29'! primGenerateToc: fileHandle useSearch: timecode doStreams: streams buffer: aString <primitive: 'primitiveMPEG3GenerateToc' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:11'! primGetFrame: aHandle stream: aStream <primitive: 'primitiveMPEG3GetFrame' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:37'! primGetPercentage: aHandle <primitive: 'primitiveMPEG3TellPercentage' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:12'! primGetSample: aHandle stream: aStream <primitive: 'primitiveMPEG3GetSample' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:15'! primGetTime: aFileHandle <primitive: 'primitiveMPEG3GetTime' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:59'! primHasAudio: aHandle <primitive: 'primitiveMPEG3HasAudio' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:59'! primHasVideo: aHandle <primitive: 'primitiveMPEG3HasVideo' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:17'! primPreviousFrame: aHandle stream: aStream <primitive: 'primitiveMPEG3PreviousFrame' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:19'! primSampleRate: aHandle stream: aStream <primitive: 'primitiveMPEG3SampleRate' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:23'! primSeekPercentage: aHandle percentage: aNumber <primitive: 'primitiveMPEG3SeekPercentage' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:27'! primSetCPUs: aHandle number: aNumber "Not support on the macintosh below OS X" <primitive: 'primitiveMPEG3SetCpus' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:29'! primSetFrame: aHandle frame: aFrameNumber stream: aStream <primitive: 'primitiveMPEG3SetFrame' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:31'! primSetMMX: aFileHandle useMMX: aValue <primitive: 'primitiveMPEG3SetMmx' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:35'! primSetSample: aHandle sample: aSampleNumber stream: aStream <primitive: 'primitiveMPEG3SetSample' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:39'! primTotalAudioStreams: aFileHandle <primitive: 'primitiveMPEG3TotalAStreams' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:40'! primTotalVideoStreams: aFileHandle <primitive: 'primitiveMPEG3TotalVStreams' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:41'! primVideoFrames: aFileHandle stream: aStream <primitive: 'primitiveMPEG3VideoFrames' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 15:41'! primVideoHeight: aFileHandle stream: aStream <primitive: 'primitiveMPEG3VideoHeight' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/19/2000 13:28'! primVideoReadNextFrameFor: aFileHandle into: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount <primitive: 'primitiveMPEG3ReadFrame' module: 'Mpeg3Plugin'> ! ! !MPEGFile methodsFor: 'primitives' stamp: 'JMM 9/18/2000 16:35'! primVideoWidth: aFileHandle stream: aStream <primitive: 'primitiveMPEG3VideoWidth' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:54'! endOfVideo: aStream "Returns true if end of video" self hasVideo ifFalse: [^true]. ^self primEndOfVideo: self fileHandle stream: aStream ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:54'! hasVideo "Returns true if file has video" ^self primHasVideo: self fileHandle ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:59'! totalVideoStreams "Returns total number of video streams" ^self primTotalVideoStreams: self fileHandle ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'! videoDropFrames: aNumberOfFrames stream: aStream "Returns -1 if setFrame failed" self hasVideo ifFalse: [^-1]. ^[self primDropFrame: self fileHandle frame: aNumberOfFrames stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'! videoFrameHeight: aStream "Returns video frame height, -1 if error " self hasVideo ifFalse: [^-1]. ^[self primVideoHeight: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'! videoFrameRate: aStream "Returns video frame rate (float), -1 if error" self hasVideo ifFalse: [^-1]. ^[self primFrameRate: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'! videoFrameWidth: aStream "Returns video frame width, -1 if error" self hasVideo ifFalse: [^-1]. ^[self primVideoWidth: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:58'! videoFrames: aStream "Total number of frames" ^(self primVideoFrames: self fileHandle stream: aStream) asInteger ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:14'! videoGetFrame: aStream "Returns frame number, or -1 if error" self hasVideo ifFalse: [^-1]. ^[(self primGetFrame: self fileHandle stream: aStream) asInteger] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:15'! videoPreviousFrame: aStream "Returns 0 if ok" self hasVideo ifFalse: [^-1]. ^[self primPreviousFrame: self fileHandle stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'video' stamp: 'jm 11/16/2001 07:53'! videoReadFrameInto: aForm stream: aStream "Read the next video frame from the given stream into the given 16- or 32-bit Form. The movie frame will be scaled to fit the Form if necessary." | colorModel bytesPerRow | ((aForm depth = 16) | (aForm depth = 32)) ifFalse: [self error: 'must use 16- or 32-bit Form']. aForm depth = 16 ifTrue: [ colorModel _ self endianness = #big ifTrue: [14] ifFalse: [16]. bytesPerRow _ 2 * (aForm width roundUpTo: 2)] ifFalse: [ colorModel _ self endianness = #big ifTrue: [13] ifFalse: [1]. bytesPerRow _ 4 * aForm width]. ^ self videoReadNextFrameInto: aForm bits x: 0 y: 0 width: (self videoFrameWidth: aStream) height: (self videoFrameHeight: aStream) outWidth: aForm width outHeight: aForm height colorModel: colorModel stream: aStream bytesPerRow: bytesPerRow ! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:15'! videoReadNextFrameInto: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount "return nonZero if failure " self hasVideo ifFalse: [^-1]. ^[self primVideoReadNextFrameFor: self fileHandle into: aFormBuffer x: x y: y width: width height: height outWidth: aTargetWidth outHeight: aTargetHeight colorModel: colorModel stream: aStream bytesPerRow: aByteCount] on: Error do: [-1] "/* Supported color models for mpeg3_read_frame */ #define MPEG3_RGB565 2 #define MPEG3_RGB555 14 //JMM for mac #define MPEG3_RGBI555 16 //SVP for intel #define MPEG3_BGR888 0 #define MPEG3_BGRA8888 1 #define MPEG3_RGB888 3 #define MPEG3_RGBA8888 4 #define MPEG3_ARGB8888 13 //JMM for mac #define MPEG3_RGBA16161616 5 /* Color models for the 601 to RGB conversion */ /* 601 not implemented for scalar code */ #define MPEG3_601_RGB565 11 #define MPEG3_601_RGB555 15 //JMM for Squeak #define MPEG3_601_RGBI555 17 //SVP for intel #define MPEG3_601_BGR888 7 #define MPEG3_601_BGRA8888 8 #define MPEG3_601_RGB888 9 #define MPEG3_601_RGBA8888 10 #define MPEG3_601_ARGB8888 12 //JMM for Squeak "! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 9/20/2000 01:58'! videoSetCPUs: aNumber self primSetCPUs: self fileHandle number: aNumber! ! !MPEGFile methodsFor: 'video' stamp: 'JMM 11/21/2000 13:15'! videoSetFrame: aFrameNumber stream: aStream "Returns -1 if setFrame failed" self hasVideo ifFalse: [^-1]. ^[self primSetFrame: self fileHandle frame: aFrameNumber asFloat stream: aStream] on: Error do: [-1] ! ! !MPEGFile methodsFor: 'private' stamp: 'JMM 9/17/2000 23:58'! register ^self class register: self! ! !MPEGFile methodsFor: 'private' stamp: 'JMM 9/17/2000 23:58'! unregister ^self class unregister: self! ! !MPEGFile commentStamp: '<historical>' prior: 0! * An interface to LibMPEG3 * Author: Adam Williams <broadcast@earthling.net> * Page: heroine.linuxbox.com * * Changed for Squeak to work with Squeak and to work on the Macintosh * Sept 2000, by John M McIntosh johnmci@smalltalkconsulting.com * The smalltalk code and the C code it produces is released under the * Squeak licence. The libmpeg3 C code is co-licenced under either the Squeak licence or * the GNU LGPL ! !MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'! register: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry add: anObject! ! !MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'! registry WeakArray isFinalizationSupported ifFalse:[^nil]. ^Registry isNil ifTrue:[Registry := WeakRegistry new] ifFalse:[Registry].! ! !MPEGFile class methodsFor: 'registry' stamp: 'JMM 9/17/2000 23:56'! unregister: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry remove: anObject ifAbsent:[]! ! !MPEGFile class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:50'! openFile: aPath ^self new openFile: aPath! ! !MPEGFile class methodsFor: 'testing' stamp: 'JMM 9/18/2000 14:28'! isFileValidMPEG: path ^self primFileValidMPEG: path! ! !MPEGFile class methodsFor: 'primitives' stamp: 'JMM 9/18/2000 14:27'! primFileValidMPEG: aPath "Check to see if the file is valid" <primitive: 'primitiveMPEG3CheckSig' module: 'Mpeg3Plugin'> self primitiveFailed! ! !MPEGMoviePlayerMorph methodsFor: '*Tools-FileList-accessing' stamp: 'bkv 11/21/2002 11:24'! moviePlayer "Enables this Morph to offer services with the FileList." ^moviePlayer ! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:11'! getPosition "answer the receiver's movie position" ^ positionSlider getScaledValue! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:53'! getVolume "answer the receiver's movie position" ^ self volumeSlider isNil ifFalse:[self volumeSlider getScaledValue] ifTrue:[0.0]! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 20:23'! guessVolumeSlider "private - look for a morph that is the receiver's volumeSlider" ^ self allMorphs detect: [:each | "first look in my own morphs" each class == SimpleSliderMorph and: [each actionSelector == #volume:]] ifNone: [| w | "second try, look all over the world (if any)" w := self world. w isNil ifFalse: ["" w allMorphs detect: [:each | "" each class == SimpleSliderMorph and: [each actionSelector == #volume:] and: [each target == moviePlayer]] ifNone: []]]! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:11'! setPosition: aNumber "changes the receiver's movie position" | newPosition | newPosition := aNumber asFloat min: 1.0 max: 0.0. positionSlider value: newPosition. moviePlayer moviePosition: newPosition! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 21:57'! setVolume: aNumber "changes the receiver's movie position" | newVolume | newVolume := aNumber asFloat min: 1.0 max: 0.0. self volumeSlider isNil ifFalse:[self volumeSlider value: newVolume]. moviePlayer volume: newVolume! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:31'! totalFrames "Answer the total number of frames in this movie." ^ moviePlayer totalFrames! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'jm 10/12/2004 11:31'! totalSeconds "Answer the total number of seconds in this movie." ^ moviePlayer totalSeconds! ! !MPEGMoviePlayerMorph methodsFor: 'accessing' stamp: 'dgd 2/15/2004 20:13'! volumeSlider "answer the receiver's volumeSlider note: if the instance var is undefined, try to get the sliders from the allMorphs chain. in this way an instance of the receiver created before the instVars was added can works fine" ^ volumeSlider ifNil: [volumeSlider := self guessVolumeSlider]! ! !MPEGMoviePlayerMorph methodsFor: 'drawing' stamp: 'jm 11/13/2001 09:12'! drawOn: aCanvas "Optimization: Do not draw myself if the movie player is one of my submorphs and the only damage is contained within it. This avoids overdrawing while playing a movie." ((moviePlayer owner == self) and: [moviePlayer bounds containsRect: aCanvas clipRect]) ifFalse: [super drawOn: aCanvas]. ! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:11'! defaultFloatPrecisionFor: aGetSelector "Answer a number indicating the default float precision to be used in a numeric readout for which the receiver provides the data. Individual morphs can override this. Showing fractional values for readouts of getCursor was in response to an explicit request from ack" aGetSelector == #getVolume ifTrue: [^ 0.01]. aGetSelector == #getPosition ifTrue: [^ 0.001]. ^ super defaultFloatPrecisionFor: aGetSelector! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 9/28/2004 17:06'! getCurrentFrameForm "Answer a Form containing the current frame scaled to the size of my display." ^ moviePlayer currentFrameScaled ! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 9/28/2004 16:59'! getCurrentFrameImageMorph "Answer an ImageMorph containing the current frame scaled to the size of my display." ^ ImageMorph new image: (moviePlayer currentFrameScaled) ! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:03'! getIsRunning "answer whateve the receiver is running" ^ moviePlayer isRunning! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:06'! getRepeat "answer whateve the receiver is running" ^ moviePlayer repeat! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:42'! getSubtitlesFileName "answer the receiver's subtitlesFileName" ^ moviePlayer subtitlesFileShortName! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:41'! getVideoFileName "answer the receiver's videoFileName" ^ moviePlayer videoFileShortName! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:30'! play "play the receiver" moviePlayer startPlaying! ]style[(4 2 19 26)f3b,f3,f3c149047000,f3! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'jm 10/12/2004 11:14'! playUntilPosition: finalPosition "Play the movie until the given position, then stop." moviePlayer playUntilPosition: finalPosition! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:31'! rewind "rewind the receiver" moviePlayer rewindMovie! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 22:07'! setRepeat: aBoolean "answer whateve the receiver is running" moviePlayer repeat: aBoolean! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:42'! setSubtitlesFileName: aString "change the subtitlesFileName" moviePlayer subtitlesFileShortName: aString! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 3/8/2004 21:41'! setVideoFileName: aString "change the videoFileName" moviePlayer videoFileShortName: aString! ! !MPEGMoviePlayerMorph methodsFor: 'e-toy support' stamp: 'dgd 2/15/2004 21:31'! stop "stop the receiver" moviePlayer stopPlaying! ! !MPEGMoviePlayerMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:34'! handlesKeyboard: evt ^ moviePlayer handlesKeyboard: evt! ! !MPEGMoviePlayerMorph methodsFor: 'event handling' stamp: 'dgd 3/7/2004 22:34'! keyStroke: evt moviePlayer keyStroke: evt ! ! !MPEGMoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:39'! defaultColor "answer the default color/fill style for the receiver" | fill | fill _ GradientFillStyle ramp: {0.0 -> (Color r: 0.355 g: 0.548 b: 1.0). 1.0 -> (Color r: 0.774 g: 0.935 b: 1.0)}. fill origin: self bounds topLeft + (61 @ 7). fill direction: 33 @ 37. fill radial: false. ^ fill! ! !MPEGMoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:40'! initialize "initialize the state of the receiver" super initialize. "" self hResizing: #shrinkWrap; vResizing: #shrinkWrap. borderWidth _ 2. self listDirection: #topToBottom. self cornerStyle: #rounded. self layoutInset: 4. moviePlayer _ MPEGDisplayMorph new. self addMorphFront: moviePlayer. self addButtonRow. self addVolumeSlider. self addPositionSlider. self extent: 10 @ 10! ! !MPEGMoviePlayerMorph methodsFor: 'stepping' stamp: 'jm 4/6/2001 07:49'! step "Update the position slider from the current movie position." positionSlider adjustToValue: moviePlayer moviePosition. ! ! !MPEGMoviePlayerMorph methodsFor: 'stepping' stamp: 'jm 5/30/2001 23:33'! stepTime "Update the position slider a few times a second." ^ 500 ! ! !MPEGMoviePlayerMorph methodsFor: 'submorphs-add/remove' stamp: 'dgd 3/8/2004 20:40'! delete "the receiver is being deleted" moviePlayer stopPlaying. moviePlayer closeFile. "" super delete! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:40'! addButtonRow "private - add the button row" | r | r _ AlignmentMorph newRow vResizing: #shrinkWrap; color: Color transparent; listCentering: #center. r addMorphBack: (self buttonName: 'Menu' translated action: #invokeMenu). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: 'Open' translated action: #openMPEGFile). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: 'Rewind' translated action: #rewindMovie). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: 'Play' translated action: #startPlaying). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: 'Stop' translated action: #stopPlaying). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). " r addMorphBack: (self buttonName: '<' action: #previousFrame). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: '>' action: #nextFrame). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). r addMorphBack: (self buttonName: 'Subtitles' translated action: #openSubtitlesFile). r addMorphBack: (Morph new extent: 3@1; color: Color transparent). " r addMorphBack: (self buildQuitButton). self addMorphBack: r. ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:40'! addPositionSlider "private - add the position slider" | r | positionSlider _ SimpleSliderMorph new color: (Color r: 0.71 g: 0.871 b: 1.0); extent: 200@2; target: moviePlayer; actionSelector: #moviePosition:; adjustToValue: 0. r _ AlignmentMorph newRow color: Color transparent; layoutInset: 0; wrapCentering: #center; cellPositioning: #leftCenter; listCentering: #center; hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: 'start ' translated). r addMorphBack: positionSlider. r addMorphBack: (StringMorph contents: ' end' translated). self addMorphBack: r. ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:40'! addVolumeSlider "private - add the volume slider" | r | volumeSlider _ SimpleSliderMorph new color: (Color r: 0.71 g: 0.871 b: 1.0); extent: 200@2; target: moviePlayer; actionSelector: #volume:; adjustToValue: 0.5. r _ AlignmentMorph newRow color: Color transparent; layoutInset: 0; wrapCentering: #center; cellPositioning: #leftCenter; listCentering: #center; hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: ' soft ' translated). r addMorphBack: volumeSlider. r addMorphBack: (StringMorph contents: ' loud' translated). self addMorphBack: r. ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:41'! buildQuitButton "private - create the [quit] button" ^ self buttonName: 'Quit' translated target: self action: #quit! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'jm 6/3/2001 23:41'! buttonFillStyle | fill | fill _ GradientFillStyle ramp: { 0.0->(Color r: 0.742 g: 0.903 b: 1.0). 1.0->(Color r: 0.516 g: 0.71 b: 1.0) }. fill origin: self bounds topLeft + (14@3). fill direction: 8@6. fill radial: false. ^ fill ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/7/2004 19:22'! buttonName: aString action: aSymbol ^ self buttonName: aString target: moviePlayer action: aSymbol ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:41'! buttonName: aString target: anObject action: selector "private - create a button" ^ SimpleButtonMorph new target: anObject; label: aString; actionSelector: selector; color: (Color gray: 0.8); "old color" fillStyle: self buttonFillStyle; borderWidth: 0; borderColor: #raised. ! ! !MPEGMoviePlayerMorph methodsFor: 'private' stamp: 'dgd 3/8/2004 20:39'! quit "quit the receiver" self delete! ! !MPEGMoviePlayerMorph commentStamp: '<historical>' prior: 0! I provide the user-interface for playing MPEG movies, including play/stop/rewind buttons and volume and position sliders. To create an instance of me, evaluate: MPEGMoviePlayerMorph new openInWorld Then use the "open" button to open an MPEG movie file. This class supplies the front panel; the real work is done by MPEGDisplayMorph and StreamingMP3Sound. ! !MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:40'! initialize "MPEGMoviePlayerMorph initialize." FileList registerFileReader: self. self registerInFlapsRegistry. ! ! !MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 19:17'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(MPEGMoviePlayerMorph authoringPrototype 'Movie Player' 'A Player for MPEG movies') forFlapNamed: 'Widgets'] ! ! !MPEGMoviePlayerMorph class methodsFor: 'class initialization' stamp: 'ads 7/30/2003 16:07'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]. FileList unregisterFileReader: self.! ! !MPEGMoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54'! fileReaderServicesForFile: fullName suffix: suffix ^((MPEGPlayer registeredVideoFileSuffixes includes: suffix ) or: [ (MPEGPlayer registeredAudioFileSuffixes includes: suffix) or: [ suffix = '*' ]] ) ifTrue: [ self services ] ifFalse: [ #() ]! ! !MPEGMoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 9/7/2004 18:17'! services "Answer the receiver's services" ^ OrderedCollection with: self servicePlayInMPEGPlayer with: self serviceOpenInMPEGPlayer ! ! !MPEGMoviePlayerMorph class methodsFor: 'parts bin' stamp: 'jm 12/17/2001 14:58'! descriptionForPartsBin ^ self partName: 'MPEGPlayer' categories: #('Multimedia') documentation: 'A player for MPEG and JPEG movies '! ! !MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'sw 9/7/2004 18:22'! openFile: aFileName "Open the given file (if not nil) in an instance of the receiver." | wrapper | aFileName ifNil: [^ Beeper beep]. wrapper _ self openOn: aFileName. wrapper openInWorld. ^ wrapper! ! !MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'sw 9/7/2004 18:22'! playFile: aFileName "Play the given file (if not nil) in an MPEGMoviePlayerMorph" | wrapper | aFileName ifNil: [^ Beeper beep]. wrapper _ self openOn: aFileName. wrapper moviePlayer startPlaying. "wrapper openInWindow." wrapper openInWorld. ^wrapper! ! !MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'sw 9/7/2004 18:17'! serviceOpenInMPEGPlayer "Answer a service for opening a file in an MPEGMoviePlayer" ^ SimpleServiceEntry provider: self label: 'open' selector: #openFile: description: 'open file in an MPEG player' buttonLabel: 'open'! ! !MPEGMoviePlayerMorph class methodsFor: 'registering' stamp: 'bkv 11/21/2002 11:47'! servicePlayInMPEGPlayer "Answer a service for opening in a MPEG player" ^ SimpleServiceEntry provider: self label: 'play in MPEG player' selector: #playFile: description: 'play in MPEG player' buttonLabel: 'play'! ! !MPEGMoviePlayerMorph class methodsFor: 'scripting' stamp: 'yo 1/14/2005 19:17'! additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #( (basic ( (command play 'Start playing the movie/sound') (command stop 'Stop playing the movie/sound') (command rewind 'Rewind the movie/sound'))) (#'movie controls' ( (slot videoFileName 'The name for the video file' String readWrite Player getVideoFileName Player setVideoFileName:) (slot subtitlesFileName 'The name for the subtitles file' String readWrite Player getSubtitlesFileName Player setSubtitlesFileName:) (slot position 'A number representing the current position of the movie/sound.' Number readWrite Player getPosition Player setPosition:) (slot volume 'A number representing the volume of the movie.' Number readWrite Player getVolume Player setVolume:) (command play 'Start playing the movie/sound') (command playUntilPosition: 'Play until the given position, then stop' Number) (command stop 'Stop playing the movie/sound') (command rewind 'Rewind the movie/sound') (slot isRunning 'Whether the movie/sound is being played' Boolean readOnly Player getIsRunning unused unused) (slot repeat 'Whether the movie/sound will play in an endless loop' Boolean readWrite Player getRepeat Player setRepeat:) (slot totalFrames 'Length of this movie in number of frames' Number readOnly Player getTotalFrames unused unused) (slot totalSeconds 'Length of this movie in seconds' Number readOnly Player getTotalSeconds unused unused) (slot frameGraphic 'A graphic for the current frame' Graphic readOnly Player getFrameGraphic unused unused) ) ) )! ! !MPEGMoviePlayerMorph class methodsFor: '*Tools-FileList-registering' stamp: 'dgd 3/8/2004 20:37'! openOn: fileNameString "open a new instance of the receiver on a file named fileNameString " | wrapper | wrapper := self new. wrapper moviePlayer openFileNamed: fileNameString. ^ wrapper! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'! audioPlayerProcess ^audioPlayerProcess ! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:39'! audioPlayerProcess: aProcess audioPlayerProcess _ aProcess! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'! clockBias ^clockBias! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'! clockBias: aArray clockBias _ aArray! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:31'! clockBiasForStream: aStream ^self clockBias at: aStream + 1.! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:32'! clockBiasForStream: aStream put: aValue self clockBias at: aStream + 1 put: aValue! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:30'! currentAudioSampleForStream: aStream ^self external audioGetSample: aStream! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:31'! currentAudioSampleForStream: aStream put: aNumber self external audioSetSample: aNumber stream: aStream! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:29'! currentVideoFrameForStream: aStream ^self external videoGetFrame: aStream! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:30'! currentVideoFrameForStream: aStream put: aNumber self external videoSetFrame: aNumber stream: aStream! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 18:33'! errorForSoundStart: aValueInMilliseconds errorForSoundStart _ aValueInMilliseconds ! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/19/2000 11:52'! external [external hasVideo] on: Error do: [(MPEGFile isFileValidMPEG: external fileName) ifFalse: [^self error: 'Mpeg File is invalid']. external _ MPEGFile openFile: external fileName]. ^external! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 11/8/2000 10:31'! fileName ^self external fileName! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:29'! form form isNil ifTrue: [self morph isNil ifTrue: [^nil]. ^self morph form]. ^form! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:37'! form: aForm form _ aForm! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:39'! frameRate ^frameRate! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:36'! frameRate: aRate frameRate _ aRate! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:04'! lastDelay ^lastDelay! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:03'! lastDelay: aNumber lastDelay _ aNumber! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:20'! morph ^morph! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/17/2000 23:20'! morph: aMorph morph _ aMorph.! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 10/20/2000 22:36'! mpegFile ^external! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'! noSound ^noSound! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:59'! noSound: flag noSound _ flag! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:59'! playerProcessPriority ^playerProcessPriority! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:59'! playerProcessPriority: aNumber playerProcessPriority _ aNumber! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/19/2000 17:34'! sampleRate ^sampleRate! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:36'! sampleRate: aRate sampleRate _ aRate! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:01'! soundQueue ^soundQueue! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:01'! soundQueue: aQueue soundQueue _ aQueue! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:38'! startTime ^startTime! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:38'! startTime: aArray startTime _ aArray! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:12'! startTimeForStream: aStream ^self startTime at: aStream + 1! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 15:11'! startTimeForStream: aStream put: aNumber ^self startTime at: aStream + 1 put: aNumber! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:03'! timeCheck ^timeCheck! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 14:02'! timeCheck: aNumber timeCheck _ aNumber! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:58'! videoPlayerProcess ^videoPlayerProcess ! ! !MPEGPlayer methodsFor: 'access' stamp: 'JMM 9/20/2000 13:58'! videoPlayerProcess: aProcess videoPlayerProcess _ aProcess! ! !MPEGPlayer methodsFor: 'access' stamp: 'kfr 11/9/2000 21:21'! volume: aVolume volume _ aVolume! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'! audioChannels: aStream ^self external audioChannels: aStream! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'! audioSampleRate: aStream ^self external audioSampleRate: aStream! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! audioSamples: aStream ^self external audioSamples: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/13/2000 20:05'! currentExternalLocationInPercent "Warning this might not return what you want, it gets percentage based on audio, or video stream based on last usage, because we buffer audio it may give incorrect information when playing mpeg movies" ^self external getPercentage! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/13/2000 20:09'! currentLocationInPercent: aStream self hasVideo ifTrue: [^ ((self currentVideoFrameForStream: aStream)/(self videoFrames: aStream)) asFloat]. self hasAudio ifTrue: [^ ((self currentAudioSampleForStream: aStream)/(self audioSamples: aStream)) asFloat]. ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:32'! endOfAudio: aStream ^self external endOfAudio: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'! endOfVideo: aStream ^self external endOfVideo: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! getTOC: timecode doStreams: streams ^self external getTOC: timecode doStreams: streams ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'! getTimeCode ^self external getTimeCode! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'! hasAudio ^self external hasAudio ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'! hasVideo ^self external hasVideo! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:31'! setMMX: aBoolean self external setMMX: aBoolean! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! totalVideoStreams ^self external totalVideoStreams ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:32'! videoDropFrames: aNumberOfFrames stream: aStream ^self external videoDropFrames: aNumberOfFrames stream: aStream! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:30'! videoFrameHeight: aStream ^self external videoFrameHeight: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'! videoFrameRate: aStream ^self external videoFrameRate: aStream! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:29'! videoFrameWidth: aStream ^self external videoFrameWidth: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! videoFrames: aStream ^self external videoFrames: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! videoPreviousFrame: aStream ^self external videoPreviousFrame: aStream ! ! !MPEGPlayer methodsFor: 'access to attributes' stamp: 'JMM 11/8/2000 10:33'! videoSetCPUs: aNumber ^self external videoSetCPUs: aNumber ! ! !MPEGPlayer methodsFor: 'audio' stamp: 'kfr 11/9/2000 22:26'! createSoundFrom: aStream | snds channels | snds _ OrderedCollection new. channels _ self audioChannels: 0. 1 to: channels do: [:c | snds add: (self readSoundChannel: c - 1 stream: aStream)]. channels = 1 ifTrue:[^ MixedSound new add: (snds at: 1) pan: 0.5 volume: volume; yourself] ifFalse: [ ^ MixedSound new add: (snds at: 1) pan: 0.0 volume: volume; add: (snds at: 2) pan: 1.0 volume: volume; yourself].! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/19/2000 18:03'! privatePlayAudioStream: aStream | number | number _ 5. self soundQueue: (QueueSound new startTime: 0). [number + 2 timesRepeat: [self soundQueue add: (self createSoundFrom: aStream)]. self soundQueue play. semaphoreForSound signal. [[self soundQueue sounds size > number] whileTrue: [(Delay forMilliseconds: 100) wait]. self soundQueue add: (self createSoundFrom: aStream). (self endOfAudio: aStream) ifTrue: [self audioPlayerProcess: nil. ^self]] repeat] on: Error do: [self audioPlayerProcess: nil. ^self]! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/19/2000 18:02'! readSoundChannel: aChannel stream: aStream | buffer result samples | samples _ (self sampleRate // 10) min: ((self audioSamples: aStream) - (self currentAudioSampleForStream: aStream)). (samples == 0) ifTrue: [self error: 'Mpeg at end of stream, toss error, catch up high']. buffer _ SoundBuffer newMonoSampleCount: samples. aChannel = 0 ifTrue: [result _ self external audioReadBuffer: buffer stream: aStream channel: aChannel] ifFalse: [result _ self external audioReReadBuffer: buffer stream: aStream channel: aChannel]. ^SampledSound samples: buffer samplingRate: self sampleRate. ! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/8/2000 10:49'! setupStream: aStream self sampleRate: (self audioSampleRate: aStream). SoundPlayer startPlayerProcessBufferSize: 8192 "(SoundPlayer bufferMSecs * self sampleRate) // 1000" rate: self sampleRate stereo: true. ! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 11/8/2000 10:33'! setupStreamNoSeek: aStream self sampleRate: (self audioSampleRate: aStream). SoundPlayer startPlayerProcessBufferSize: 8192 "(SoundPlayer bufferMSecs * self sampleRate) // 1000" rate: self sampleRate stereo: ((self audioChannels: aStream) > 1). ! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 9/20/2000 13:38'! startAudioPlayerProcess: aStream self audioPlayerProcess: ([self privatePlayAudioStream: aStream] forkAt: Processor userInterruptPriority)! ! !MPEGPlayer methodsFor: 'audio' stamp: 'JMM 9/19/2000 16:59'! updateSoundStream: aStream! ! !MPEGPlayer methodsFor: 'delay' stamp: 'JMM 11/8/2000 15:30'! calculateDelayGivenFrame: frame stream: aStream | estimated current delta | current _ Time millisecondClockValue - (self startTimeForStream: aStream). estimated _ ((frame asFloat / self frameRate) * 1000) asInteger - (self clockBiasForStream: aStream). delta _ estimated - current. delta > 33 ifTrue: [self lastDelay: (delta + self lastDelay) // 2. (Delay forMilliseconds: self lastDelay) wait]. delta < -33 ifTrue: [self lastDelay: self lastDelay // 2. self decideToSkipAFrame: delta averageWait: current//frame stream: aStream]. ! ! !MPEGPlayer methodsFor: 'delay' stamp: 'JMM 11/8/2000 10:13'! calculateDelayToSoundGivenFrame: frame stream: aStream | current delta buffers estimatedAudio estimatedVideo | current _ Time millisecondClockValue - (self startTimeForStream: aStream) + (self clockBiasForStream: aStream). buffers _ (self soundQueue sounds size - 1 ) max: 0. buffers = 0 ifTrue: [^self]. estimatedAudio _ ((self currentAudioSampleForStream: aStream) - (buffers * self sampleRate // 10) - self soundQueue currentSound samplesRemaining) * 1000 / self sampleRate. estimatedAudio _ estimatedAudio - 0000. estimatedVideo _ ((frame asFloat / self frameRate) * 1000) asInteger. delta _ estimatedVideo - estimatedAudio. delta > 100 ifTrue: [self lastDelay < delta ifTrue: [self lastDelay: self lastDelay + (((delta-self lastDelay)/10) max: 1)]. (Delay forMilliseconds: self lastDelay) wait]. delta < -100 ifTrue: [self lastDelay: ((self lastDelay - 10) max: 1). self decideToSkipAFrame: delta averageWait: current//frame stream: aStream]. ! ! !MPEGPlayer methodsFor: 'delay' stamp: 'JMM 11/8/2000 14:28'! decideToSkipAFrame: delta averageWait: aWaitTime stream: aStream | estimatedFrames | delta abs > aWaitTime ifTrue: [estimatedFrames _ ( delta abs / (1000 / self frameRate)) asInteger. self videoDropFrames: estimatedFrames stream: aStream].! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 11/8/2000 10:31'! close self external closeFile! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'kfr 11/9/2000 21:19'! initialize: aPath (MPEGFile isFileValidMPEG: aPath) ifFalse: [^nil]. external _ MPEGFile openFile: aPath. self playerProcessPriority: Processor userSchedulingPriority. self lastDelay: 10. volume _ 1.0. errorForSoundStart _ 500. semaphoreForSound _ Semaphore new. self startTime: (Array new: self totalVideoStreams). self clockBias: (Array new: self totalVideoStreams withAll: 0).! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:06'! initializeWithFileName: aPath self initialize: aPath. self form: nil. ^self! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:06'! initializeWithFileName: aPath form: aForm self initialize: aPath. self form: aForm. ^self! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 10/17/2000 23:34'! initializeWithFileName: aPath morph: aMorphic self initialize: aPath. self morph: aMorphic. ^self! ! !MPEGPlayer methodsFor: 'initialize-release' stamp: 'JMM 9/20/2000 14:15'! stopAndClose self stop. self close ! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'! playAudioStream: aStream self hasAudio ifFalse: [^self]. self setupStream: aStream. self startAudioPlayerProcess: aStream.! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'! playAudioStreamNoSeek: aStream self hasAudio ifFalse: [^self]. self setupStreamNoSeek: aStream. self startAudioPlayerProcess: aStream.! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'! playAudioStreamWaitTilDone: aStream self hasAudio ifFalse: [^self]. self setupStream: aStream. self privatePlayAudioStream: aStream.! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'! playStream: aStream self noSound: self hasAudio not. self startVideoPlayerProcess: aStream ! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 11/8/2000 10:20'! playStreamWaitTilDone: aStream self noSound: self hasAudio not. self privatePlayVideoStream: aStream.! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 9/20/2000 14:00'! playVideoStream: aStream self noSound: true. self startVideoPlayerProcess: aStream ! ! !MPEGPlayer methodsFor: 'play' stamp: 'JMM 9/20/2000 14:00'! playVideoStreamWaitTilDone: aStream self noSound: true. self privatePlayVideoStream: aStream ! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:38'! backAudio: aNumber forStream: aStream self forwardAudio: (0-aNumber) forStream: aStream! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:39'! backVideo: aNumber forStream: aStream self forwardVideo: (0-aNumber) forStream: aStream! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/13/2000 19:35'! forwardAudio: aNumber forStream: aStream | newLocation | self hasAudio ifFalse: [^self]. newLocation _ (((self currentAudioSampleForStream: aStream) + aNumber) min: (self audioSamples: aStream)) max: 0 . self currentAudioSampleForStream: aStream put: newLocation! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/13/2000 19:35'! forwardVideo: aNumber forStream: aStream | newLocation | self hasVideo ifFalse: [^self]. newLocation _ (((self currentVideoFrameForStream: aStream) + aNumber) min: (self videoFrames: aStream)) max: 0. self currentVideoFrameForStream: aStream put: newLocation. ! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/19/2000 12:50'! isPlaying ^((self audioPlayerProcess isNil) and: [self videoPlayerProcess isNil]) not! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/13/2000 19:37'! recalculateNewSampleLocationForStream: aStream givenFrame: aFrame | estimated | self hasAudio ifFalse: [^self]. estimated _ (aFrame / (self videoFrames: aStream) * (self audioSampleRate: aStream)) asInteger. self currentAudioSampleForStream: aStream put: estimated.! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/8/2000 10:47'! seekToHere: aPercentage forStream: aStream "Alternate method is to seek all video/audio for stream to a certain percentage using the primitive, but I think your mpeg must have timecodes!! otherwise endless loop" self external seekPercentage: aPercentage! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/19/2000 11:44'! seekVideoAudioBasedOnFrame: aFrame forStream: aStream self external hasVideo ifTrue: [self currentVideoFrameForStream: aStream put: aFrame]. self recalculateNewSampleLocationForStream: aStream givenFrame: aFrame! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 11/10/2000 00:19'! setLocation: aPercentage forStream: aStream self hasAudio ifTrue: [self currentAudioSampleForStream: aStream put: ((self audioSamples: aStream) * aPercentage) asInteger]. self hasVideo ifTrue: [self currentVideoFrameForStream: aStream put: ((self videoFrames: aStream) * aPercentage) asInteger].! ! !MPEGPlayer methodsFor: 'play controls' stamp: 'JMM 9/20/2000 18:46'! stop self videoPlayerProcess notNil ifTrue: [self videoPlayerProcess terminate. self videoPlayerProcess: nil]. self audioPlayerProcess notNil ifTrue: [self audioPlayerProcess terminate. self audioPlayerProcess: nil. SoundPlayer stopPlayingAll]! ! !MPEGPlayer methodsFor: 'utility' stamp: 'JMM 10/17/2000 23:22'! changed self morph notNil ifTrue: [self morph changed].! ! !MPEGPlayer methodsFor: 'utility' stamp: 'JMM 11/8/2000 10:25'! checkForm: aStream | y x | self form notNil ifTrue: [^self]. y _ self videoFrameHeight: aStream. x _ self videoFrameWidth: aStream. self form: (Form extent: x@y depth: 32) ! ! !MPEGPlayer methodsFor: 'video' stamp: 'JMM 11/19/2000 12:47'! privatePlayVideoStream: aStream | location | self hasVideo ifFalse: [self timeCheck: 0@0. ^self]. self checkForm: aStream. self frameRate: (self videoFrameRate: aStream). location _ self currentVideoFrameForStream: aStream. self clockBiasForStream: aStream put: (1/self frameRate*location*1000) asInteger. self videoLoop: aStream. self timeCheck: ((Time millisecondClockValue + (self clockBiasForStream: aStream) - (self startTimeForStream: aStream))/1000.0) @ ((self videoFrames: aStream) / self frameRate). self videoPlayerProcess: nil! ! !MPEGPlayer methodsFor: 'video' stamp: 'JMM 9/20/2000 13:59'! startVideoPlayerProcess: aStream self videoPlayerProcess: ([self privatePlayVideoStream: aStream] forkAt: self playerProcessPriority)! ! !MPEGPlayer methodsFor: 'video' stamp: 'jm 12/17/2001 09:36'! videoLoop: aStream | location oneTime | oneTime _ true. [self external videoReadFrameInto: self form stream: aStream. oneTime ifTrue: [oneTime _ false. self noSound ifFalse: [self playAudioStreamNoSeek: aStream. semaphoreForSound wait. (Delay forMilliseconds: errorForSoundStart) wait]. self startTimeForStream: aStream put: (Time millisecondClockValue)]. self morph ifNil: [self form == Display ifTrue: [Display forceToScreen] ifFalse: [self form displayOn: Display]]. self changed. location _ (self currentVideoFrameForStream: aStream)+1. true ifTrue: [self calculateDelayGivenFrame: location stream: aStream] ifFalse: [self calculateDelayToSoundGivenFrame: location stream: aStream]. (self endOfVideo: aStream) ifTrue: [^self]] repeat.! ! !MPEGPlayer commentStamp: '<historical>' prior: 0! V1.01 johnmci@smalltalkconsulting.com Nov 8th 2000 A Simple MPEG Player for playing MPEG3 audio or video | foo | foo _ MpegPlayer playFile: 'my.mpg'. foo playStream: 0. "To play both audio and video, stream #0 " foo playAudioStream: 0 "To play audio stream". foo playVideoStream: 0 "To play video stream" foo playStreamWaitTilDone: 0 "To play audio/video as currrent process" or | foo | foo _ MPEGPlayer playFile: 'my.mpg' onForm: Display. foo playStream: 0. To play full screen. ! !MPEGPlayer class methodsFor: 'file suffixes' stamp: 'bkv 11/21/2002 15:28'! registeredAudioFileSuffixes "Answer the file extensions for which MPEGPlayer registers audio services with FileList." "MPEGPlayer registeredAudioFileSuffixes" ^{ 'mp3'. } ! ! !MPEGPlayer class methodsFor: 'file suffixes' stamp: 'bkv 11/21/2002 11:14'! registeredVideoFileSuffixes "Answer the file extensions for which MPEGPlayer registers video services with FileList." "MPEGPlayer registeredVideoFileSuffixes" ^{ 'mpg'. 'mpeg'. 'jmv'. } ! ! !MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 9/18/2000 19:02'! playFile: aPath ^self new initializeWithFileName: aPath ! ! !MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 9/18/2000 18:32'! playFile: aPath onForm: aForm ^self new initializeWithFileName: aPath form: aForm! ! !MPEGPlayer class methodsFor: 'instance creation' stamp: 'JMM 10/17/2000 23:19'! playFile: aPath onMorph: aMorph ^self new initializeWithFileName: aPath morph: aMorph! ! !MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:04'! is: text in: aStream " Returns true if text is present in aStream. Advance the stream if present. " | position | (text isKindOf: Character) ifTrue: [ ^self is: (String with: text) in: aStream ]. position := aStream position. aStream skipSeparators. text = (aStream next: text size) ifFalse: [ aStream position: position. ^false ]. ^true! ! !MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:01'! mustBe: text in: aStream " Check text to be present in aStream. " (text isKindOf: Character) ifTrue: [ ^self is: (String with: text) in: aStream ]. (self is: text in: aStream) ifFalse: [ ^self error: 'Invalid token, must be: ',text ].! ! !MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:05'! nextIntegerFrom: aStream " Returns the next Integer present in aStream. " | sign result | sign := (self is: $- in: aStream) ifTrue: [-1] ifFalse: [1]. result := 0. self skipBlanks: aStream. [aStream peek isDigit] whileTrue: [ result := aStream next asciiValue - $0 asciiValue + (result * 10) ]. ^result * sign! ! !MPEGSubtitleElement methodsFor: 'parsing' stamp: 'dgd 3/8/2004 20:17'! readFrom: aStream "Private - Read the receiver's contents from aStream." self mustBe: '{' in: aStream. initialFrame := self nextIntegerFrom: aStream. self mustBe: '}{' in: aStream. endFrame := self nextIntegerFrom: aStream. self mustBe: '}' in: aStream. "" self contents: aStream nextLine isoToSqueak! ! !MPEGSubtitleElement methodsFor: 'parsing' stamp: 'asm 7/30/2003 21:42'! skipBlanks: aStream " Advance aStream skipping all blank characters and comments. " aStream skipSeparators! ! !MPEGSubtitleElement methodsFor: 'printing' stamp: 'dgd 3/8/2004 20:50'! printOn: aStream "append to aStream a sequence of characters that identifies the receiver." aStream nextPutAll: '{'; nextPutAll: initialFrame asString; nextPutAll: '}{'; nextPutAll: endFrame asString; nextPutAll: '}'; nextPutAll: contents asString! ! !MPEGSubtitleElement methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:17'! contents "answer the receiver's contents" ^ contents! ! !MPEGSubtitleElement methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:17'! contents: aString "change the receiver's contents" contents := aString replaceAll: $| with: Character cr! ! !MPEGSubtitleElement methodsFor: 'testing' stamp: 'dgd 3/8/2004 20:23'! correspondsToFrame: aNumber "answer if the receiver corresponds to a given frame number" ^ aNumber between: initialFrame and: endFrame! ! !MPEGSubtitleElement commentStamp: 'asm 7/31/2003 22:27' prior: 0! an element of a subtitle file, this has the form {initialFrame}{endFrame} subtitle line[| next subtitle line]! !MPEGSubtitleElement class methodsFor: 'instance creation' stamp: 'asm 7/30/2003 21:26'! fromStream: aStream "Returns an instance of the receiver read from aStream." ^self new readFrom: aStream! ! !MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:49'! elementCorrespondingToFrame: frameNumber "answer the element corresponding to frameNumber" ^ elements detect: [:each | each correspondsToFrame: frameNumber] ifNone: []! ! !MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 22:45'! fileName "answer the receiver's fileName" ^ fileName! ! !MPEGSubtitles methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:42'! subtitleForFrame: frameNumber "answer the subtitle for the given frame number" | element | element := self elementCorrespondingToFrame: frameNumber. ^ element isNil ifTrue: [''] ifFalse: [element contents]! ! !MPEGSubtitles methodsFor: 'initialization' stamp: 'dgd 3/8/2004 22:24'! initializeFromFileNamed: aString "initialize the receiver from a file named aString" | file result | fileName := aString. elements := OrderedCollection new. "" file := CrLfFileStream readOnlyFileNamed: aString. [result := self readFrom: file] ensure: [file close]. ^ result! ! !MPEGSubtitles methodsFor: 'initialization' stamp: 'dgd 3/8/2004 22:04'! readFrom: aStream "private - Read the next definitions found in aStream onto the receiver" [aStream atEnd] whileFalse: [| element | element := MPEGSubtitleElement fromStream: aStream. elements add: element]! ! !MPEGSubtitles commentStamp: 'asm 7/31/2003 22:12' prior: 0! a subtitle file i can only read subtitle files with a format like this: [..] {1043}{1082}La gente siempre me pregunta|si conozco a Tyler Durden. {1083}{1096}Tres minutos. {1097}{1133}El momento de la verdad.|Punto cero. [..] from Fight Club while reading, pipes(|) are replaced by carriage returns ! !MPEGSubtitles class methodsFor: 'instance creation' stamp: 'dgd 3/8/2004 22:02'! fromFileNamed: aString "Returns an instance of the receiver read from file named aString" ^self new initializeFromFileNamed: aString ! ! !MPEGSubtitlesDisplayer methodsFor: 'accessing' stamp: 'dgd 3/7/2004 21:18'! font "answer the receiver's font" ^ font ifNil: [TextStyle defaultFont] ! ! !MPEGSubtitlesDisplayer methodsFor: 'accessing' stamp: 'dgd 3/8/2004 20:33'! font: aFont "change the receiver's font" font := aFont. "" self contents: ''. self contents: self contentsFromTarget! ! !MPEGSubtitlesDisplayer methodsFor: 'initialization' stamp: 'dgd 3/7/2004 21:16'! initialize "initialiaze the receiver" super initialize. "" font := TextStyle defaultFont."" self backgroundColor: (Color black alpha: 0.4). "" self margins: 4 @ 2. self textColor: Color white. self textStyle centered! ! !MPEGSubtitlesDisplayer methodsFor: 'menu' stamp: 'dgd 3/8/2004 20:42'! changeFont "open a dialog to change the receiver's font" | newFont | newFont := StrikeFont fromUser: self font. "" newFont isNil ifFalse: [self font: newFont]! ! !MPEGSubtitlesDisplayer methodsFor: 'menu' stamp: 'dgd 3/8/2004 20:10'! changeSubtitlesColor "offer a ColorPicker to change the subtitles colors" ColorPickerMorph new choseModalityFromPreference; sourceHand: self activeHand; target: self; selector: #textColor:; originalColor: self textColor; putUpFor: self currentHand near: self currentHand cursorBounds ! ! !MPEGSubtitlesDisplayer methodsFor: 'stepping and presenter' stamp: 'dgd 3/7/2004 20:59'! step "update my position" super step. " if my owner is the mpegplayer, i change my position to bottomCenter" self owner == self target ifTrue: [| bc | bc := self owner bottomCenter. self left: bc x - (self width // 2). self bottom: bc y]! ! !MPEGSubtitlesDisplayer methodsFor: 'target access' stamp: 'dgd 3/8/2004 20:36'! contentsFromTarget "private - answer the contents from the receiver's target" | contentsAsText | contentsAsText := super contentsFromTarget asText. contentsAsText addAttribute: (TextFontReference toFont: self font). ^ contentsAsText! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'ar 3/17/2001 23:43'! displayAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." Smalltalk isMorphic ifFalse: [^ self]. ActiveWorld addMorph: self centeredNear: aPoint. self world displayWorld. "show myself" aBlock value. self delete! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'nk 4/6/2002 22:33'! informUserAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." | title w | Smalltalk isMorphic ifFalse: [^ self]. title _ self allMorphs detect: [ :ea | ea hasProperty: #titleString ]. title _ title submorphs first. self visible: false. w _ ActiveWorld. aBlock value:[:string| self visible ifFalse:[ w addMorph: self centeredNear: aPoint. self visible: true]. title contents: string. self setConstrainedPosition: Sensor cursorPoint hangOut: false. self changed. w displayWorld "show myself" ]. self delete. w displayWorld! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'ar 12/27/2001 22:46'! invokeAt: aPoint in: aWorld "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." ^ self invokeAt: aPoint in: aWorld allowKeyboard: Preferences menuKeyboardControl! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'KLC 4/11/2004 10:56'! invokeAt: aPoint in: aWorld allowKeyboard: aBoolean "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." | w originalFocusHolder | self flag: #bob. "is <aPoint> global or local?" self flag: #arNote. "<aPoint> is local to aWorld" originalFocusHolder _ aWorld primaryHand keyboardFocus. self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. done _ false. w _ aWorld outermostWorldMorph. "containing hand" [self isInWorld & done not] whileTrue: [w doOneSubCycle]. self delete. originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. ^ mvcSelection ! ! !MVCMenuMorph methodsFor: 'initializing' stamp: 'laza 4/20/2004 10:41'! initialize super initialize. self setProperty: #morphicLayerNumber toValue: self morphicLayerNumber ! ! !MVCMenuMorph methodsFor: 'WiW support' stamp: 'laza 4/20/2004 10:38'! morphicLayerNumber ^self valueOfProperty: #morphicLayerNumber ifAbsent: [10]. ! ! !MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:38'! resetViewBox | c | (c := worldState canvas) isNil ifTrue: [^self resetViewBoxForReal]. c form == Display ifFalse: [^self resetViewBoxForReal]. c origin = (0 @ 0) ifFalse: [^self resetViewBoxForReal]. c clipRect extent = self viewBox extent ifFalse: [^self resetViewBoxForReal]! ! !MVCWiWPasteUpMorph methodsFor: 'project' stamp: 'di 11/16/2001 09:42'! project ^ Project current! ! !MVCWiWPasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:38'! viewBox: newViewBox | vb | worldState resetDamageRecorder. "since we may have moved, old data no longer valid" ((vb := self viewBox) isNil or: [vb ~= newViewBox]) ifTrue: [worldState canvas: nil]. worldState viewBox: newViewBox. self bounds: newViewBox. "works better here than simply storing into bounds" worldState assuredCanvas. "Paragraph problem workaround; clear selections to avoid screen droppings:" self flag: #arNote. "Probably unnecessary" worldState handsDo: [:h | h releaseKeyboardFocus]. self fullRepaintNeeded! ! !MacFileDirectory methodsFor: 'file operations' stamp: 'yo 12/19/2003 21:15'! fullPathFor: path "Return the fully-qualified path name for the given file." path isEmptyOrNil ifTrue: [^ pathName asSqueakPathName]. (self class isAbsolute: path) ifTrue: [^ path]. pathName asSqueakPathName = '' "Root dir?" ifTrue: [ ^path]. ^(path first = $:) ifTrue: [ pathName asSqueakPathName, path ] ifFalse: [pathName asSqueakPathName, ':' , path]! ! !MacFileDirectory methodsFor: 'as yet unclassified' stamp: 'hmm 3/25/2004 21:57'! fullNameFor: fileName "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." "Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm. Also note that this method is tolerent of a nil argument -- is simply returns nil in this case." "Fix by hmm: for a file in the root directory of a volume on MacOS, the filePath (name of the directory) is not recognizable as an absolute path anymore (it has no delimiters). Therefore, the original fileName is tested for absoluteness, and the filePath is only made absolute if the original fileName was not absolute" | correctedLocalName prefix | fileName isEmptyOrNil ifTrue: [^ fileName]. DirectoryClass splitName: fileName to: [:filePath :localName | correctedLocalName _ localName isEmpty ifFalse: [self checkName: localName fixErrors: true] ifTrue: [localName]. prefix _ (DirectoryClass isAbsolute: fileName) ifTrue: [filePath] ifFalse: [self fullPathFor: filePath]]. prefix isEmpty ifTrue: [^correctedLocalName]. prefix last = self pathNameDelimiter ifTrue:[^ prefix, correctedLocalName] ifFalse:[^ prefix, self slash, correctedLocalName]! ! !MacFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'! isActiveDirectoryClass ^ super isActiveDirectoryClass and: [(SmalltalkImage current getSystemAttribute: 1201) isNil or: [(SmalltalkImage current getSystemAttribute: 1201) asNumber <= 31]]! ! !MacFileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'! makeAbsolute: path "Ensure that path looks like an absolute path" | absolutePath | (self isAbsolute: path) ifTrue: [ ^path ]. "If a path begins with a colon, it is relative." absolutePath _ (path first = $:) ifTrue: [ path copyWithoutFirst ] ifFalse: [ path ]. (self isAbsolute: absolutePath) ifTrue: [ ^absolutePath ]. "Otherwise, if it contains a colon anywhere, it is absolute and the first component is the volume name." ^absolutePath, ':'! ! !MacFileDirectory class methodsFor: 'platform specific' stamp: 'nk 3/13/2003 10:59'! makeRelative: path "Ensure that path looks like an relative path" ^path first = $: ifTrue: [ path ] ifFalse: [ ':', path ]! ! !MacFileDirectory class methodsFor: 'platform specific' stamp: 'hg 9/28/2001 15:23'! maxFileNameLength ^31! ! !MacFileDirectory class methodsFor: 'class initialization' stamp: 'nk 12/5/2002 11:17'! isAbsolute: fileName "Return true if the given fileName is absolute. The rules are: If a path begins with a colon, it is relative. Otherwise, If it contains a colon anywhere, it is absolute and the first component is the volume name. Otherwise, It is relative." ^fileName first ~= $: and: [ fileName includes: $: ]! ! !MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:05'! testMacFileDirectory "(self run: #testMacFileDirectory)" "This fails before the the fix if the Squeak directory is on the root directory like: 'HardDisk:Squeak' But should work both before and after the fix of John if there is several directories in the hieracry: HardDisk:User:Squeak" "If somebody can find a way to make the test failed all the time when the fix is not present we should replace it" self assert: (FileDirectory default fullName) = (FileDirectory default fullNameFor: (FileDirectory default fullName))! ! !MacFileDirectoryTest methodsFor: 'test' stamp: 'nk 7/30/2004 17:54'! testMacFileFullPathFor "(self run: #testMacFileFullPathFor)" SmalltalkImage current platformName = 'Mac OS' ifTrue: [self assert: (MacFileDirectory isAbsolute: (FileDirectory default fullPathFor: FileDirectory default fullName)). self deny: (MacFileDirectory isAbsolute: (FileDirectory on: 'Data') pathName)]! ! !MacFileDirectoryTest methodsFor: 'test' stamp: 'kfr 7/28/2004 15:06'! testMacIsAbsolute "(self selector: #testMacIsAbsolute) run" self deny: (MacFileDirectory isAbsolute: 'Volumes'). self assert: (MacFileDirectory isAbsolute: 'Volumes:Data:Stef'). self deny: (MacFileDirectory isAbsolute: ':Desktop:test.st')! ! !MacFileDirectoryTest methodsFor: 'test' stamp: 'sd 10/27/2003 18:02'! testMakeAbsolute self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: 'Data')). self assert: (MacFileDirectory isAbsolute: (MacFileDirectory makeAbsolute: ':Data')). ! ! !MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'md 10/26/2003 13:06'! isActiveDirectoryClass "Ok, lets see if we support HFS Plus file names, the long ones" ^ (self pathNameDelimiter = self primPathNameDelimiter) and: [(SmalltalkImage current getSystemAttribute: 1201) notNil and: [(SmalltalkImage current getSystemAttribute: 1201) asNumber > 31]]! ! !MacHFSPlusFileDirectory class methodsFor: 'platform specific' stamp: 'JMM 11/14/1935 00:02'! maxFileNameLength ^ 255! ! !MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/18/2003 15:22'! fromSystemClipboard: aString ^ aString squeakToIso. ! ! !MacRomanClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'ka 12/2/2003 17:10'! toSystemClipboard: aString | result | aString isOctetString ifTrue: [^ aString asOctetString isoToSqueak]. result _ WriteStream on: (String new: aString size). aString do: [:each | each asciiValue < 256 ifTrue: [result nextPut: each isoToSqueak]]. ^ result contents. ! ! !MacRomanInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 1/18/2005 08:57'! nextCharFrom: sensor firstEvt: evtBuf | keyValue | keyValue := evtBuf third. ^ keyValue asCharacter squeakToIso. ! ! !MacRomanTextConverter methodsFor: 'conversion' stamp: 'yo 7/19/2004 18:35'! nextFromStream: aStream | character1 | aStream isBinary ifTrue: [^ aStream basicNext]. character1 _ aStream basicNext. character1 isNil ifTrue: [^ nil]. character1 charCode = 165 ifTrue: [^ (Character value: 183)]. ^ character1 squeakToIso. ! ! !MacRomanTextConverter methodsFor: 'conversion' stamp: 'yo 3/1/2005 05:45'! nextPut: aCharacter toStream: aStream aStream isBinary ifTrue: [ aCharacter class == Character ifTrue: [ aStream basicNextPut: aCharacter. ^ aStream. ]. aCharacter class == MultiCharacter ifTrue: [ aStream nextInt32Put: aCharacter value. ^ aStream. ]. ]. aStream basicNextPut: aCharacter isoToSqueak. ! ! !MacRomanTextConverter methodsFor: 'friend' stamp: 'yo 8/5/2003 22:20'! currentCharSize ^ 1. ! ! !MacRomanTextConverter methodsFor: 'friend' stamp: 'yo 8/4/2003 12:33'! leadingChar ^ 0. ! ! !MacRomanTextConverter commentStamp: '<historical>' prior: 0! Text converter for Mac Roman. An encoding used for the languages originated from Western Europe area.! !MacRomanTextConverter class methodsFor: 'utilities' stamp: 'yo 8/4/2003 12:33'! encodingNames ^ #('mac-roman' ) copy ! ! !MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 3/15/2004 08:38'! fromSystemClipboard: aString ^ aString convertFromWithConverter: ShiftJISTextConverter new! ! !MacShiftJISClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'tetha 3/15/2004 08:37'! toSystemClipboard: text | string | "self halt." string _ text asString. string isAsciiString ifTrue: [^ string asOctetString]. string isOctetString ifTrue: [^ string "hmm"]. ^ string convertToWithConverter: ShiftJISTextConverter new . ! ! !MacShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/13/2003 13:45'! initialize converter _ ShiftJISTextConverter new. ! ! !MacShiftJISInputInterpreter methodsFor: 'as yet unclassified' stamp: 'sumim 8/29/2003 15:25'! nextCharFrom: sensor firstEvt: evtBuf | firstChar secondChar peekEvent keyValue type stream multiChar | keyValue _ evtBuf third. evtBuf fourth = EventKeyChar ifTrue: [type _ #keystroke]. peekEvent _ sensor peekEvent. (peekEvent notNil and: [peekEvent fourth = EventKeyDown]) ifTrue: [ sensor nextEvent. peekEvent _ sensor peekEvent]. (type == #keystroke and: [peekEvent notNil and: [peekEvent first = EventTypeKeyboard and: [peekEvent fourth = EventKeyChar]]]) ifTrue: [ firstChar _ keyValue asCharacter. secondChar _ (peekEvent third) asCharacter. stream _ ReadStream on: (String with: firstChar with: secondChar). multiChar _ converter nextFromStream: stream. multiChar isOctetCharacter ifFalse: [sensor nextEvent]. ^ multiChar]. ^ keyValue asCharacter! ! !MacUnicodeInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 3/17/2004 22:12'! nextCharFrom: sensor firstEvt: evtBuf | keyValue | keyValue := evtBuf third. keyValue < 256 ifTrue: [^ (Character value: keyValue) squeakToIso]. "Smalltalk systemLanguage charsetClass charFromUnicode: keyValue." ^ Unicode value: keyValue. ! ! !MagnifierMorph methodsFor: 'accessing' stamp: 'nk 3/6/2004 10:14'! showPointer: aBoolean "If aBoolean is true, display the current pointer position as a small square in the center of the lens." showPointer == aBoolean ifTrue: [ ^self ]. showPointer _ aBoolean. self changed.! ! !MagnifierMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !MagnifierMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !MagnifierMorph methodsFor: 'initialization' stamp: 'nk 3/6/2004 10:47'! initialize "initialize the state of the receiver" super initialize. trackPointer _ true. showPointer _ false. magnification _ 2. self extent: 128 @ 128! ! !MagnifierMorph methodsFor: 'magnifying' stamp: 'nk 3/17/2004 11:34'! magnifiedForm "Answer the magnified form" | srcRect form exclusion magnified | srcRect := self sourceRectFrom: self sourcePoint. (RecursionLock isNil and: [ self showPointer or: [ srcRect intersects: self bounds ]]) ifTrue: [RecursionLock := self. exclusion := self isRound ifTrue: [owner] ifFalse: [self]. form := self currentWorld patchAt: srcRect without: exclusion andNothingAbove: false. RecursionLock := nil] ifFalse: ["cheaper method if the source is not occluded" form := Display copy: srcRect]. "smooth if non-integer scale" magnified := form magnify: form boundingBox by: magnification smoothing: (magnification isInteger ifTrue: [1] ifFalse: [2]). "display the pointer rectangle if desired" self showPointer ifTrue: [magnified reverse: (magnified center - (2 @ 2) extent: 4 @ 4) fillColor: Color white]. ^ magnified! ! !MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/6/2004 10:15'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine; add: 'magnification...' translated action: #chooseMagnification; addUpdating: #trackingPointerString action: #toggleTrackingPointer; addUpdating: #showingPointerString action: #toggleShowingPointer; addUpdating: #toggleRoundString action: #toggleRoundness.! ! !MagnifierMorph methodsFor: 'menu' stamp: 'md 11/16/2003 15:14'! chooseMagnification | result | result _ (SelectionMenu selections: #(1.5 2 4 8)) startUpWithCaption: ('Choose magnification (currently {1})' translated format:{magnification}). (result isNil or: [result = magnification]) ifTrue: [^ self]. magnification _ result. self extent: self extent. "round to new magnification" self changed. "redraw even if extent wasn't changed"! ! !MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:34'! showPointer ^showPointer ifNil: [ showPointer _ false ].! ! !MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:34'! showingPointerString ^ (self showPointer ifTrue: ['stop showing pointer'] ifFalse: ['start showing pointer']) translated! ! !MagnifierMorph methodsFor: 'menu' stamp: 'nk 3/17/2004 11:35'! toggleShowingPointer self showPointer: self showPointer not! ! !MagnifierMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:51'! trackingPointerString ^ (trackPointer ifTrue: ['stop tracking pointer'] ifFalse: ['start tracking pointer']) translated! ! !MagnifierMorph methodsFor: 'round view' stamp: 'dgd 8/30/2003 21:51'! toggleRoundString ^ (self isRound ifTrue: ['be square'] ifFalse: ['be round']) translated! ! !MagnifierMorph commentStamp: '<historical>' prior: 0! MagnifierMorph instances are magnifying lenses that magnify the morphs below them (if grabbed or if trackPointer is false) or the area around the mouse pointer. Instance variables: magnification <Number> The magnification to use. If non-integer, smooths the magnified form. trackPointer <Boolean> If set, magnifies the area around the Hand. If not, magnfies the area underneath the magnifier center. showPointer <Boolean> If set, display a small reversed rectangle in the center of the lens. Also enables the display of Morphs in the Hand itself. srcExtent <Rectangle> The extent of the source rectangle. Class variables: RecursionLock <MagnifierMorph|nil> Used to avoid infinite recursion when getting the source patch to display.! !MagnifierMorph class methodsFor: 'instance creation' stamp: 'sw 6/25/2001 13:33'! newRound "Answer a round Magnifier" | aMagnifier sm | aMagnifier _ self new. sm _ ScreeningMorph new position: aMagnifier position. sm addMorph: aMagnifier. sm addMorph: (EllipseMorph newBounds: aMagnifier bounds). sm setNameTo: 'Magnifier'. ^ sm! ! !MagnifierMorph class methodsFor: 'instance creation' stamp: 'nk 3/6/2004 10:28'! newShowingPointer "Answer a Magnifier that also displays Morphs in the Hand and the Hand position" ^(self new) showPointer: true; setNameTo: 'HandMagnifier'; yourself! ! !MagnifierMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 15:04'! descriptionForPartsBin ^ self partName: 'Magnifier' categories: #('Useful') documentation: 'A magnifying glass'! ! !MagnifierMorph class methodsFor: 'parts bin' stamp: 'nk 3/6/2004 10:27'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'RoundGlass' categoryList: #(Useful) documentation: 'A round magnifying glass' globalReceiverSymbol: #MagnifierMorph nativitySelector: #newRound. DescriptionForPartsBin formalName: 'Hand Magnifier' categoryList: #(Useful) documentation: 'A magnifying glass that also shows Morphs in the Hand and displays the Hand position.' globalReceiverSymbol: #MagnifierMorph nativitySelector: #newShowingPointer }! ! !MagnifierMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:14'! initialize self registerInFlapsRegistry.! ! !MagnifierMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:14'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(MagnifierMorph newRound 'Magnifier' 'A magnifying glass') forFlapNamed: 'Widgets']! ! !MagnifierMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:37'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Magnitude commentStamp: '<historical>' prior: 0! Magnitude has methods for dealing with linearly ordered collections. Subclasses represent dates, times, and numbers. Example for interval-testing (answers a Boolean): 7 between: 5 and: 10 No instance-variables. ! !MailAddressParserTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:48'! setUp "I am the method in which your test is initialized. If you have ressources to build, put them here."! ! !MailAddressParserTest methodsFor: 'initialize-release' stamp: 'md 3/17/2003 15:48'! tearDown "I am called whenever your test ends. I am the place where you release the ressources"! ! !MailAddressParserTest methodsFor: 'testing' stamp: 'md 3/17/2003 15:54'! testAddressesIn | testString correctAnswer | testString _ 'joe@lama.com, joe2@lama.com joe3@lama.com joe4 , Not an Address <joe5@address>, joe.(annoying (nested) comment)literal@[1.2.3.4], "an annoying" group : joe1@groupie, joe2@groupie, "Joey" joe3@groupy, "joe6"."joe8"@group.com;, Lex''s email account <lex>'. correctAnswer _ #('joe@lama.com' 'joe2@lama.com' 'joe3@lama.com' 'joe4' 'joe5@address' 'joe.literal@[1.2.3.4]' 'joe1@groupie' 'joe2@groupie' '"Joey"' 'joe3@groupy' '"joe6"."joe8"@group.com' 'lex') asOrderedCollection. self should: [(MailAddressParser addressesIn: testString) = correctAnswer].! ! !MailAddressParserTest commentStamp: '<historical>' prior: 0! This is the unit test for the class MailAddressParser. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'mas 2/8/2001 11:36'! nextComment | start nestLevel paren | start _ pos. pos _ pos + 1. nestLevel _ 1. [ nestLevel > 0 ] whileTrue: [ pos _ text indexOfAnyOf: CSParens startingAt: pos ifAbsent: [ 0 ]. pos = 0 ifTrue: [ self error: 'unterminated comment. ie, more (''s than )''s' ]. paren _ self nextChar. paren = $( ifTrue: [ nestLevel _ nestLevel + 1 ] ifFalse: [ nestLevel _ nestLevel - 1 ]]. ^ MailAddressToken type: #Comment text: (text copyFrom: start to: pos - 1)! ! !MailAddressTokenizer class methodsFor: 'class initialization' stamp: 'ls 12/2/2001 15:15'! initialize "Initalize class variables using MailAddressTokenizer initialize" | atomChars | CSParens _ CharacterSet empty. CSParens addAll: '()'. CSSpecials _ CharacterSet empty. CSSpecials addAll: '()<>@,;:\".[]'. CSNonSeparators _ CharacterSet separators complement. "(from RFC 2822)" atomChars := CharacterSet empty. atomChars addAll: ($A to: $Z). atomChars addAll: ($a to: $z). atomChars addAll: ($0 to: $9). atomChars addAll: '!!#$%^''*+-/=?^_`{|}~'. CSNonAtom := atomChars complement.! ! !MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 13:57'! breakLines: aString atWidth: width "break lines in the given string into shorter lines" | result start end atAttachment | result _ WriteStream on: (String new: (aString size * 50 // 49)). atAttachment _ false. aString asString linesDo: [ :line | (line beginsWith: '====') ifTrue: [ atAttachment _ true ]. atAttachment ifTrue: [ "at or after an attachment line; no more wrapping for the rest of the message" result nextPutAll: line. result cr ] ifFalse: [ (line beginsWith: '>') ifTrue: [ "it's quoted text; don't wrap it" result nextPutAll: line. result cr. ] ifFalse: [ "regular old line. Wrap it to multiple lines" start _ 1. "output one shorter line each time through this loop" [ start + width <= line size ] whileTrue: [ "find the end of the line" end _ start + width - 1. [end >= start and: [ (line at: (end+1)) isSeparator not ]] whileTrue: [ end _ end - 1 ]. end < start ifTrue: [ "a word spans the entire width!!" end _ start + width - 1 ]. "copy the line to the output" result nextPutAll: (line copyFrom: start to: end). result cr. "get ready for next iteration" start _ end+1. (line at: start) isSeparator ifTrue: [ start _ start + 1 ]. ]. "write out the final part of the line" result nextPutAll: (line copyFrom: start to: line size). result cr. ]. ]. ]. ^result contents! ! !MailComposition methodsFor: 'private' stamp: 'ls 2/10/2001 14:08'! breakLinesInMessage: message "reformat long lines in the specified message into shorter ones" message body mainType = 'text' ifTrue: [ "it's a single-part text message. reformat the text" | newBodyText | newBodyText := self breakLines: message bodyText atWidth: 72. message body: (MIMEDocument contentType: message body contentType content: newBodyText). ^self ]. message body isMultipart ifTrue: [ "multipart message; process the top-level parts. HACK: the parts are modified in place" message parts do: [ :part | part body mainType = 'text' ifTrue: [ | newBodyText | newBodyText := self breakLines: part bodyText atWidth: 72. part body: (MIMEDocument contentType: part body contentType content: newBodyText) ] ]. message regenerateBodyFromParts. ].! ! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'! messageText "return the current text" ^messageText. ! ! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'! messageText: aText "change the current text" messageText _ aText. self changed: #messageText. ^true! ! !MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'! smtpServer ^MailSender smtpServer! ! !MailComposition methodsFor: 'access' stamp: 'mir 5/12/2003 16:04'! submit | message | "submit the message" textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. message := MailMessage from: messageText asString. self breakLinesInMessage: message. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: self smtpServer. morphicWindow ifNotNil: [morphicWindow delete]. mvcWindow ifNotNil: [mvcWindow controller close]! ! !MailComposition methodsFor: 'interface' stamp: 'mdr 4/10/2001 14:27'! addAttachment | file fileResult fileName | textEditor ifNotNil: [self hasUnacceptedEdits ifTrue: [textEditor accept]]. (fileResult _ StandardFileMenu oldFile) ifNotNil: [fileName _ fileResult directory fullNameFor: fileResult name. file _ FileStream readOnlyFileNamed: fileName. file ifNotNil: [file binary. self messageText: ((MailMessage from: self messageText asString) addAttachmentFrom: file withName: fileResult name; text). file close]] ! ! !MailComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:11'! open "open an interface" Smalltalk isMorphic ifTrue: [ self openInMorphic ] ifFalse: [ self openInMVC ]! ! !MailComposition methodsFor: 'interface' stamp: 'ls 10/16/1998 09:17'! openInMVC | textView sendButton | mvcWindow _ StandardSystemView new label: 'Mister Postman'; minimumSize: 400@250; model: self. textView _ PluggableTextView on: self text: #messageText accept: #messageText:. textEditor _ textView controller. sendButton _ PluggableButtonView on: self getState: nil action: #submit. sendButton label: 'Send'. sendButton borderWidth: 1. sendButton window: (1@1 extent: 398@38). mvcWindow addSubView: sendButton. textView window: (0@40 corner: 400@250). mvcWindow addSubView: textView below: sendButton. mvcWindow controller open. ! ! !MailComposition methodsFor: 'interface' stamp: 'RAA 1/17/2001 14:20'! openInMorphic "open an interface for sending a mail message with the given initial text " | textMorph buttonsList sendButton attachmentButton | morphicWindow _ SystemWindow labelled: 'Mister Postman'. morphicWindow model: self. textEditor _ textMorph _ PluggableTextMorph on: self text: #messageText accept: #messageText:. morphicWindow addMorph: textMorph frame: (0 @ 0.1 corner: 1 @ 1). buttonsList _ AlignmentMorph newRow. sendButton _ PluggableButtonMorph on: self getState: nil action: #submit. sendButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'send message'; setBalloonText: 'add this to the queue of messages to be sent'; onColor: Color white offColor: Color white. buttonsList addMorphBack: sendButton. attachmentButton _ PluggableButtonMorph on: self getState: nil action: #addAttachment. attachmentButton hResizing: #spaceFill; vResizing: #spaceFill; label: 'add attachment'; setBalloonText: 'Send a file with the message'; onColor: Color white offColor: Color white. buttonsList addMorphBack: attachmentButton. morphicWindow addMorph: buttonsList frame: (0 @ 0 extent: 1 @ 0.1). morphicWindow openInMVC! ! !MailComposition methodsFor: 'interface' stamp: 'dvf 5/11/2002 01:23'! sendMailMessage: aMailMessage self messageText: aMailMessage text! ! !MailComposition commentStamp: '<historical>' prior: 0! a message being composed. When finished, it will be submitted via a Celeste.! !MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! initialize super initialize. MailSender register: self.! ! !MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 01:25'! sendMailMessage: aMailMessage | newComposition | newComposition _ self new. newComposition messageText: aMailMessage text; open! ! !MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! unload MailSender unregister: self ! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:48'! body: newBody "change the body" body := newBody. text := nil.! ! !MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:58'! from: aString "Parse aString to initialize myself." | parseStream contentType bodyText contentTransferEncoding | text _ aString withoutTrailingBlanks, String cr. parseStream _ ReadStream on: text. contentType _ 'text/plain'. contentTransferEncoding _ nil. fields := Dictionary new. "Extract information out of the header fields" self fieldsFrom: parseStream do: [:fName :fValue | "NB: fName is all lowercase" fName = 'content-type' ifTrue: [contentType _ (fValue copyUpTo: $;) asLowercase]. fName = 'content-transfer-encoding' ifTrue: [contentTransferEncoding _ fValue asLowercase]. (fields at: fName ifAbsentPut: [OrderedCollection new: 1]) add: (MIMEHeaderValue forField: fName fromString: fValue)]. "Extract the body of the message" bodyText _ parseStream upToEnd. contentTransferEncoding = 'base64' ifTrue: [bodyText _ Base64MimeConverter mimeDecodeToChars: (ReadStream on: bodyText). bodyText _ bodyText contents]. contentTransferEncoding = 'quoted-printable' ifTrue: [bodyText _ bodyText decodeQuotedPrintable]. body _ MIMEDocument contentType: contentType content: bodyText! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 2/10/2001 12:15'! initialize "initialize as an empty message" text _ String cr. fields := Dictionary new. body _ MIMEDocument contentType: 'text/plain' content: String cr! ! !MailMessage methodsFor: 'initialize-release' stamp: 'ls 3/18/2001 16:20'! setField: fieldName to: aFieldValue "set a field. If any field of the specified name exists, it will be overwritten" fields at: fieldName asLowercase put: (OrderedCollection with: aFieldValue). text := nil.! ! !MailMessage methodsFor: 'initialize-release' stamp: 'mdr 4/11/2001 11:59'! setField: fieldName toString: fieldValue ^self setField: fieldName to: (MIMEHeaderValue forField: fieldName fromString: fieldValue)! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:34'! cc ^self fieldsNamed: 'cc' separatedBy: ', '! ! !MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:19'! date "Answer a date string for this message." ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) printFormat: #(2 1 3 47 1 2)! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:27'! fields "return the internal fields structure. This is private and subject to change!!" ^ fields! ! !MailMessage methodsFor: 'access' stamp: 'mdr 3/21/2001 15:28'! from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:26'! name "return a default name for this part, if any was specified. If not, return nil" | type nameField disposition | "try in the content-type: header" type _ self fieldNamed: 'content-type' ifAbsent: [nil]. (type notNil and: [(nameField _ type parameters at: 'name' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "try in content-disposition:" disposition _ self fieldNamed: 'content-disposition' ifAbsent: [nil]. (disposition notNil and: [(nameField _ disposition parameters at: 'filename' ifAbsent: [nil]) notNil]) ifTrue: [^ nameField]. "give up" ^ nil! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:24'! subject ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! ! !MailMessage methodsFor: 'access' stamp: 'ls 2/10/2001 12:49'! text "the full, unprocessed text of the message" text ifNil: [ self regenerateText ]. ^text! ! !MailMessage methodsFor: 'access' stamp: 'mdr 4/7/2001 17:48'! time | dateField | dateField := (self fieldNamed: 'date' ifAbsent: [ ^0 ]) mainValue. ^ [self timeFrom: dateField] ifError: [:err :rcvr | Date today asSeconds]. ! ! !MailMessage methodsFor: 'access' stamp: 'ls 3/18/2001 16:35'! to ^self fieldsNamed: 'to' separatedBy: ', '! ! !MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43'! fieldsFrom: aStream do: aBlock "Invoke the given block with each of the header fields from the given stream. The block arguments are the field name and value. The streams position is left right after the empty line separating header and body." | savedLine line s | savedLine _ self readStringLineFrom: aStream. [aStream atEnd] whileFalse: [ line _ savedLine. (line isEmpty) ifTrue: [^self]. "quit when we hit a blank line" [savedLine _ self readStringLineFrom: aStream. (savedLine size > 0) and: [savedLine first isSeparator]] whileTrue: [ "lines starting with white space are continuation lines" s _ ReadStream on: savedLine. s skipSeparators. line _ line, ' ', s upToEnd]. self reportField: line withBlanksTrimmed to: aBlock]. "process final header line of a body-less message" (savedLine isEmpty) ifFalse: [self reportField: savedLine withBlanksTrimmed to: aBlock]. ! ! !MailMessage methodsFor: 'parsing' stamp: 'dvf 5/10/2002 21:43'! readStringLineFrom: aStream "Read and answer the next line from the given stream. Consume the carriage return but do not append it to the string." | | ^aStream upTo: Character cr! ! !MailMessage methodsFor: 'parsing' stamp: 'mdr 2/11/2001 17:58'! reportField: aString to: aBlock "Evaluate the given block with the field name a value in the given field. Do nothing if the field is malformed." | s fieldName fieldValue | (aString includes: $:) ifFalse: [^self]. s _ ReadStream on: aString. fieldName _ (s upTo: $:) asLowercase. "fieldname must be lowercase" fieldValue _ s upToEnd withBlanksTrimmed. fieldValue isEmpty ifFalse: [aBlock value: fieldName value: fieldValue]. ! ! !MailMessage methodsFor: 'parsing' stamp: 'ajh 10/1/2001 17:10'! timeFrom: aString "Parse the date and time (rfc822) and answer the result as the number of seconds since the start of 1980." | s t rawDelta delta plusOrMinus | s _ ReadStream on: aString. "date part" t _ ((self readDateFrom: s) ifNil: [Date today]) asSeconds. [s atEnd or: [s peek isAlphaNumeric]] whileFalse: [s next]. "time part" s atEnd ifFalse: ["read time part (interpreted as local, regardless of sender's timezone)" (s peek isDigit) ifTrue: [t _ t + (Time readFrom: s) asSeconds]. ]. s skipSeparators. "Check for a numeric time zone offset" ('+-' includes: s peek) ifTrue: [plusOrMinus _ s next. rawDelta _ (s peek isDigit) ifTrue: [Integer readFrom: s] ifFalse: [0]. delta _ (rawDelta // 100 * 60 + (rawDelta \\ 100)) * 60. t _ plusOrMinus = $+ ifTrue: [t - delta] ifFalse: [t + delta]]. "We ignore text time zone offsets like EST, GMT, etc..." ^ t - (Date newDay: 1 year: 1980) asSeconds "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 -500'" "MailMessage new timeFrom: 'Thu, 22 Jun 2000 14:17:47 --500'" "MailMessage new timeFrom: 'on, 04 apr 2001 14:57:32'"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'yo 7/26/2004 22:06'! bodyTextFormatted "Answer a version of the text in my body suitable for display. This will parse multipart forms, decode HTML, and other such things" "check for multipart" self body isMultipart ifTrue: [ "check for alternative forms" self body isMultipartAlternative ifTrue: [ "it's multipart/alternative. search for a part that we can display, biasing towards nicer formats" #('text/html' 'text/plain') do: [ :format | self parts do: [ :part | part body contentType = format ifTrue: [ ^part bodyTextFormatted ] ] ]. "couldn't find a desirable part to display; just display the first part" ^self parts first bodyTextFormatted ]. "not alternative parts. put something for each part" ^Text streamContents: [ :str | self parts do: [ :part | ((#('text' 'multipart') includes: part body mainType) or: [ part body contentType = 'message/rfc822']) ifTrue: [ "try to inline the message part" str nextPutAll: part bodyTextFormatted. ] ifFalse: [ |descript | str cr. descript := part name ifNil: [ 'attachment' ]. str nextPutAll: (Text string: '[', descript, ']' attribute: (TextMessageLink message: part)). ] ] ]. ]. "check for HTML" (self body contentType = 'text/html') ifTrue: [ Smalltalk at: #HtmlParser ifPresentAndInMemory: [ :htmlParser | ^(htmlParser parse: (ReadStream on: body content)) formattedText ] ]. "check for an embedded message" self body contentType = 'message/rfc822' ifTrue: [ ^(MailMessage from: self body content) formattedText ]. "nothing special--just return the text" ^body content. ! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'yo 7/26/2004 22:06'! cleanedHeader "Reply with a cleaned up version email header. First show fields people would normally want to see (in a regular order for easy browsing), and then any other fields not explictly excluded" | new priorityFields omittedFields | new _ WriteStream on: (String new: text size). priorityFields _ #('Date' 'From' 'Subject' 'To' 'Cc'). omittedFields _ MailMessage omittedHeaderFields. "Show the priority fields first, in the order given in priorityFields" priorityFields do: [ :pField | "We don't check whether the priority field is in the omitted list!!" self headerFieldsNamed: pField do: [: fValue | new nextPutAll: pField, ': ', fValue decodeMimeHeader; cr]]. "Show the rest of the fields, omitting the uninteresting ones and ones we have already shown" omittedFields _ omittedFields, priorityFields. self fieldsFrom: (ReadStream on: text) do: [: fName : fValue | ((fName beginsWith: 'x-') or: [omittedFields anySatisfy: [: omitted | fName sameAs: omitted]]) ifFalse: [new nextPutAll: fName, ': ', fValue; cr]]. ^new contents! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'mdr 5/7/2001 11:07'! excerpt "Return a short excerpt of the text of the message" ^ self bodyText withSeparatorsCompacted truncateWithElipsisTo: 60! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'RAA 2/16/2001 07:40'! fieldsAsMimeHeader "return the entire header in proper MIME format" self halt. "This no longer appears to be used and since, as a result of recent changes, it references an undeclared variable <subject>, I have commented out the code to clean up the inspection of undeclared vars" "--- | strm | strm _ WriteStream on: (String new: 100). self fields associationsDo: [:e | strm nextPutAll: e key; nextPutAll: ': '; nextPutAll: (e key = 'subject' ifTrue: [subject] ifFalse: [e value asHeaderValue]); cr]. ^ strm contents ---"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 11/11/2001 13:27'! printOn: aStream "For text parts with no filename show: 'text/plain: first line of text...' for attachments/filenamed parts show: 'attachment: filename.ext'" | name | aStream nextPutAll: ((name _ self name) ifNil: ['Text: ' , self excerpt] ifNotNil: ['File: ' , name])! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'bkv 6/23/2003 14:17'! regenerateBodyFromParts "regenerate the message body from the multiple parts" | bodyText | bodyText := String streamContents: [ :str | str cr. parts do: [ :part | str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; cr; nextPutAll: part text ]. str cr; nextPutAll: '--'; nextPutAll: self attachmentSeparator; nextPutAll: '--'; cr ]. body := MIMEDocument contentType: 'multipart/mixed' content: bodyText. text := nil. "text needs to be reformatted"! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'ls 3/18/2001 16:27'! regenerateText "regenerate the full text from the body and headers" | encodedBodyText | text := String streamContents: [ :str | "first put the header" fields keysAndValuesDo: [ :fieldName :fieldValues | fieldValues do: [ :fieldValue | str nextPutAll: fieldName capitalized ; nextPutAll: ': '; nextPutAll: fieldValue asHeaderValue; cr ]. ]. "skip a line between header and body" str cr. "put the body, being sure to encode it according to the header" encodedBodyText := body content. self decoderClass ifNotNil: [ encodedBodyText := (self decoderClass mimeEncode: (ReadStream on: encodedBodyText)) upToEnd ]. str nextPutAll: encodedBodyText ].! ! !MailMessage methodsFor: 'printing/formatting' stamp: 'nk 6/12/2004 09:36'! viewImageInBody | stream image | stream _ self body contentStream. image _ Form fromBinaryStream: stream. (World drawingClass withForm: image) openInWorld! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:04'! addAttachmentFrom: aStream withName: aName "add an attachment, encoding with base64. aName is the option filename to encode" | newPart | self makeMultipart. self parts. "make sure parts have been parsed" "create the attachment as a MailMessage" newPart := MailMessage empty. newPart setField: 'content-type' toString: 'application/octet-stream'. newPart setField: 'content-transfer-encoding' toString: 'base64'. aName ifNotNil: [ | dispositionField | dispositionField := MIMEHeaderValue fromMIMEHeader: 'attachment'. dispositionField parameterAt: 'filename' put: aName. newPart setField: 'content-disposition' to: dispositionField ]. newPart body: (MIMEDocument contentType: 'application/octet-stream' content: aStream upToEnd). "regenerate our text" parts := parts copyWith: newPart. self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 5/7/2001 11:22'! atomicParts "Answer all of the leaf parts of this message, including those of multipart included messages" self body isMultipart ifFalse: [^ OrderedCollection with: self]. ^ self parts inject: OrderedCollection new into: [:col :part | col , part atomicParts]! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 3/22/2001 09:06'! attachmentSeparator ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters at: 'boundary' ifAbsent: [^nil]! ! !MailMessage methodsFor: 'multipart' stamp: 'ls 3/18/2001 16:26'! decoderClass | encoding | encoding _ self fieldNamed: 'content-transfer-encoding' ifAbsent: [^ nil]. encoding _ encoding mainValue. encoding asLowercase = 'base64' ifTrue: [^ Base64MimeConverter]. encoding asLowercase = 'quoted-printable' ifTrue: [^ QuotedPrintableMimeConverter]. ^ nil! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 4/11/2001 12:06'! makeMultipart "if I am not multipart already, then become a multipart message with one part" | part multipartHeader | body isMultipart ifTrue: [ ^self ]. "set up the new message part" part := MailMessage empty. part body: body. (self hasFieldNamed: 'content-type') ifTrue: [ part setField: 'content-type' to: (self fieldNamed: 'content-type' ifAbsent: ['']) ]. parts := Array with: part. "fix up our header" multipartHeader := MIMEHeaderValue fromMIMEHeader: 'multipart/mixed'. multipartHeader parameterAt: 'boundary' put: self class generateSeparator . self setField: 'content-type' to: multipartHeader. self setField: 'mime-version' to: (MIMEHeaderValue fromMIMEHeader: '1.0'). self removeFieldNamed: 'content-transfer-encoding'. "regenerate everything" self regenerateBodyFromParts. text := nil.! ! !MailMessage methodsFor: 'multipart' stamp: 'mdr 3/23/2001 13:30'! parseParts "private -- parse the parts of the message and store them into a collection" | parseStream msgStream messages separator | "If this is not multipart, store an empty collection" self body isMultipart ifFalse: [parts _ #(). ^self]. "If we can't find a valid separator, handle it as if the message is not multipart" separator := self attachmentSeparator. separator ifNil: [Transcript show: 'Ignoring bad attachment separater'; cr. parts _ #(). ^self]. separator := '--', separator withoutTrailingBlanks. parseStream _ ReadStream on: self bodyText. msgStream _ LimitingLineStreamWrapper on: parseStream delimiter: separator. msgStream limitingBlock: [:aLine | aLine withoutTrailingBlanks = separator or: "Match the separator" [aLine withoutTrailingBlanks = (separator, '--')]]. "or the final separator with --" "Throw away everything up to and including the first separator" msgStream upToEnd. msgStream skipThisLine. "Extract each of the multi-parts as strings" messages _ OrderedCollection new. [parseStream atEnd] whileFalse: [messages add: msgStream upToEnd. msgStream skipThisLine]. parts _ messages collect: [:e | MailMessage from: e]! ! !MailMessage methodsFor: 'multipart' stamp: 'st 9/18/2004 23:40'! save "save the part to a file" | fileName file | fileName _ self name ifNil: ['attachment' , Utilities dateTimeSuffix]. (fileName includes: $.) ifFalse: [ #(isJpeg 'jpg' isGif 'gif' isPng 'png' isPnm 'pnm') pairsDo: [ :s :e | (self body perform: s) ifTrue: [fileName _ fileName, '.', e] ] ]. fileName _ FillInTheBlank request: 'File name for save?' initialAnswer: fileName. fileName isEmpty ifTrue: [^ nil]. file _ FileStream newFileNamed: fileName. file nextPutAll: self bodyText. file close! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:32'! fieldNamed: aString ifAbsent: aBlock | matchingFields | "return the value of the field with the specified name. If there is more than one field, then return the first one" matchingFields := fields at: aString asLowercase ifAbsent: [ ^aBlock value ]. ^matchingFields first! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:21'! fieldsNamed: aString ifAbsent: aBlock "return a list of all fields with the given name" ^fields at: aString asLowercase ifAbsent: aBlock! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:36'! fieldsNamed: aString separatedBy: separationString "return all fields with the specified name, concatenated together with separationString between each element. Return an empty string if no fields with the specified name are present" | matchingFields | matchingFields := self fieldsNamed: aString ifAbsent: [ ^'' ]. ^String streamContents: [ :str | matchingFields do: [ :field | str nextPutAll: field mainValue ] separatedBy: [ str nextPutAll: separationString ]]. ! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:28'! hasFieldNamed: aString ^fields includesKey: aString asLowercase! ! !MailMessage methodsFor: 'fields' stamp: 'ls 3/18/2001 16:30'! removeFieldNamed: name "remove all fields with the specified name" fields removeKey: name ifAbsent: []! ! !MailMessage methodsFor: 'fields' stamp: 'ls 2/10/2001 13:47'! rewriteFields: aBlock append: appendBlock "Rewrite header fields. The body is not modified. Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header." | old new result appendString | self halt: 'this method is out of date. it needs to update body, at the very least. do we really need this now that we have setField:to: and setField:toString: ?!!'. old _ ReadStream on: text. new _ WriteStream on: (String new: text size). self fieldsFrom: old do: [ :fName :fValue | result _ aBlock value: fName value: fValue. result ifNil: [new nextPutAll: fName, ': ', fValue; cr] ifNotNil: [result isEmpty ifFalse: [new nextPutAll: result. result last = Character cr ifFalse: [new cr]]]]. appendString _ appendBlock value. appendString isEmptyOrNil ifFalse: [new nextPutAll: appendString. appendString last = Character cr ifFalse: [new cr]]. new cr. "End of header" text _ new contents, old upToEnd. ! ! !MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'! containsViewableImage ^self body isJpeg | self body isGif | self body isPng! ! !MailMessage methodsFor: 'testing' stamp: 'mdr 4/11/2001 19:44'! selfTest "For testing only: Check that this instance is well formed and makes sense" self formattedText. [MailAddressParser addressesIn: self from] ifError: [ :err :rcvr | Transcript show: 'Error parsing From: (', self from, ') ', err]. [MailAddressParser addressesIn: self to] ifError: [ :err :rcvr | Transcript show: 'Error parsing To: (', self to, ') ', err]. [MailAddressParser addressesIn: self cc] ifError: [ :err :rcvr | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. ! ! !MailMessage commentStamp: '<historical>' prior: 0! I represent an Internet mail or news message. text - the raw text of my message body - the body of my message, as a MIMEDocument fields - a dictionary mapping lowercased field names into collections of MIMEHeaderValue's parts - if I am a multipart message, then this is a cache of my parts! !MailMessage class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:08'! empty "return a message with no text and no header" ^self new! ! !MailMessage class methodsFor: 'preferences' stamp: 'mdr 7/9/2001 13:23'! omittedHeaderFields "Reply a list of fields to omit when displaying a nice simple message" "Note that heads of the form X-something: value are filtered programatically. This is done since we don't want any of them and it is impossible to predict them in advance." ^ #( 'comments' 'priority' 'disposition-notification-to' 'content-id' 'received' 'return-path' 'newsgroups' 'message-id' 'path' 'in-reply-to' 'sender' 'fonts' 'mime-version' 'status' 'content-type' 'content-transfer-encoding' 'errors-to' 'keywords' 'references' 'nntp-posting-host' 'lines' 'return-receipt-to' 'precedence' 'originator' 'distribution' 'content-disposition' 'importance' 'resent-to' 'resent-cc' 'resent-message-id' 'resent-date' 'resent-sender' 'resent-from' 'delivered-to' 'user-agent' 'content-class' 'thread-topic' 'thread-index' 'list-help', 'list-post', 'list-subscribe', 'list-id', 'list-unsubscribe', 'list-archive' ) ! ! !MailMessage class methodsFor: 'testing' stamp: 'mdr 3/21/2001 15:59'! selfTest | msgText msg | msgText _ 'Date: Tue, 20 Feb 2001 13:52:53 +0300 From: mdr@scn.rg (Me Ru) Subject: RE: Windows 2000 on your laptop To: "Greg Y" <to1@mail.com> cc: cc1@scn.org, cc1also@test.org To: to2@no.scn.org, to2also@op.org cc: cc2@scn.org Hmmm... Good. I will try to swap my German copy for something in English, and then do the deed. Oh, and expand my RAM to 128 first. Mike '. msg _ self new from: msgText. [msg text = msgText] assert. [msg subject = 'RE: Windows 2000 on your laptop'] assert. [msg from = 'mdr@scn.rg (Me Ru)'] assert. [msg date = '2/20/01'] assert. [msg time = 667133573] assert. "[msg name] assert." [msg to = '"Greg Y" <to1@mail.com>, to2@no.scn.org, to2also@op.org'] assert. [msg cc = 'cc1@scn.org, cc1also@test.org, cc2@scn.org'] assert. "MailMessage selfTest" ! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 01:31'! isSmtpServerSet ^ SmtpServer notNil and: [SmtpServer notEmpty] ! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'ads 5/11/2003 21:11'! sendMessage: aMailMessage self default ifNotNil: [self default sendMailMessage: aMailMessage]! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 01:34'! setSmtpServer "Set the SMTP server used to send outgoing messages via" SmtpServer ifNil: [SmtpServer _ '']. SmtpServer _ FillInTheBlank request: 'What is your mail server for outgoing mail?' initialAnswer: SmtpServer. ! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'yo 7/26/2004 22:47'! setUserName "Change the user's email name for use in composing messages." (UserName isNil) ifTrue: [UserName _ '']. UserName _ FillInTheBlank request: 'What is your email address?\(This is the address other people will reply to you)' withCRs initialAnswer: UserName. UserName ifNotNil: [UserName _ UserName]! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 01:29'! smtpServer "Answer the server for sending email" self isSmtpServerSet ifFalse: [self setSmtpServer]. SmtpServer isEmpty ifTrue: [ self error: 'no SMTP server specified' ]. ^SmtpServer! ! !MailSender class methodsFor: 'as yet unclassified' stamp: 'dvf 5/11/2002 00:49'! userName "Answer the user name to be used in composing messages." (UserName isNil or: [UserName isEmpty]) ifTrue: [self setUserName]. UserName isEmpty ifTrue: [ self error: 'no user name specified' ]. ^UserName! ! !MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 00:47'! activate "Activate a Celeste window for the receiver" MailSender sendMessage: (MailMessage from: self composeText)! ! !MailtoUrl methodsFor: 'downloading' stamp: 'dvf 5/11/2002 01:00'! composeText "Answer the template for a new message." ^ String streamContents: [:str | str nextPutAll: 'From: '. str nextPutAll: MailSender userName; cr. str nextPutAll: 'To: '. str nextPutAll: locator asString; cr. str nextPutAll: 'Subject: '; cr. str cr].! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! anyOne ^contents anyOne! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! at: row at: column ^contents at: (self indexForRow: row andColumn: column)! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/28/2002 14:14'! at: r at: c ifInvalid: v "If r,c is a valid index for this matrix, answer the corresponding element. Otherwise, answer v." (r between: 1 and: nrows) ifFalse: [^v]. (c between: 1 and: ncols) ifFalse: [^v]. ^contents at: (r-1)*ncols + c ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 12:37'! at: row at: column incrementBy: value "Array2D>>at:at:add: was the origin of this method, but in Smalltalk add: generally suggests adding an element to a collection, not doing a sum. This method, and SequenceableCollection>>at:incrementBy: that supports it, have been renamed to reveal their intention more clearly." ^contents at: (self indexForRow: row andColumn: column) incrementBy: value! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:40'! at: row at: column put: value ^contents at: (self indexForRow: row andColumn: column) put: value! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:42'! atAllPut: value contents atAllPut: value! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom ^contents atRandom ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom: aGenerator ^contents atRandom: aGenerator! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! columnCount ^ncols! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ^self identityIndexOf: anElement ifAbsent: [0@0] ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ifAbsent: anExceptionBlock ^self rowAndColumnForIndex: (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value]) ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:13'! indexOf: anElement "If there are integers r, c such that (self at: r at: c) = anElement, answer some such r@c, otherwise answer 0@0. This kind of perverse result is provided by analogy with SequenceableCollection>>indexOf:. The order in which the receiver are searched is UNSPECIFIED except that it is the same as the order used by #indexOf:ifAbsent: and #readStream." ^self indexOf: anElement ifAbsent: [0@0] ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 11/22/2002 13:10'! indexOf: anElement ifAbsent: anExceptionBlock "If there are integers r, c such that (self at: r at: c) = anElement, answer some such r@c, otherwise answer the result of anExceptionBlock." ^self rowAndColumnForIndex: (contents indexOf: anElement ifAbsent: [^anExceptionBlock value]) ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! replaceAll: oldObject with: newObject contents replaceAll: oldObject with: newObject! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! rowCount ^nrows! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! size ^contents size! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:52'! swap: r1 at: c1 with: r2 at: c2 contents swap: (self indexForRow: r1 andColumn: c1) with: (self indexForRow: r2 andColumn: c2)! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:41'! atColumn: column |p| p _ (self indexForRow: 1 andColumn: column)-ncols. ^(1 to: nrows) collect: [:row | contents at: (p _ p+ncols)] ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! atColumn: column put: aCollection |p| aCollection size = nrows ifFalse: [self error: 'wrong column size']. p _ (self indexForRow: 1 andColumn: column)-ncols. aCollection do: [:each | contents at: (p _ p+ncols) put: each]. ^aCollection ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/21/2002 23:32'! atRow: row (row between: 1 and: nrows) ifFalse: [self error: '1st subscript out of range']. ^contents copyFrom: (row-1)*ncols+1 to: row*ncols! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/22/2002 12:42'! atRow: row put: aCollection |p| aCollection size = ncols ifFalse: [self error: 'wrong row size']. p _ (self indexForRow: row andColumn: 1)-1. aCollection do: [:each | contents at: (p _ p+1) put: each]. ^aCollection! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/23/2002 20:41'! diagonal "Answer (1 to: (nrows min: ncols)) collect: [:i | self at: i at: i]" |i| i _ ncols negated. ^(1 to: (nrows min: ncols)) collect: [:j | contents at: (i _ i + ncols + 1)]! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:21'! swapColumn: anIndex withColumn: anotherIndex |a b| a _ self indexForRow: 1 andColumn: anIndex. b _ self indexForRow: 1 andColumn: anotherIndex. nrows timesRepeat: [ contents swap: a with: b. a _ a + ncols. b _ b + ncols]. ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 11/28/2002 14:22'! swapRow: anIndex withRow: anotherIndex |a b| a _ self indexForRow: anIndex andColumn: 1. b _ self indexForRow: anotherIndex andColumn: 1. ncols timesRepeat: [ contents swap: a with: b. a _ a + 1. b _ b + 1]. ! ! !Matrix methodsFor: 'accessing rows/columns' stamp: 'raok 10/22/2002 00:13'! transposed self assert: [nrows = ncols]. ^self indicesCollect: [:row :column | self at: column at: row]! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:09'! atRows: rs columns: cs "Answer a Matrix obtained by slicing the receiver. rs and cs should be sequenceable collections of positive integers." ^self class rows: rs size columns: cs size tabulate: [:r :c | self at: (rs at: r) at: (cs at: c)]! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:30'! atRows: r1 to: r2 columns: c1 to: c2 "Answer a submatrix [r1..r2][c1..c2] of the receiver." |rd cd| rd _ r1 - 1. cd _ c1 - 1. ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd] ! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 13:05'! atRows: r1 to: r2 columns: c1 to: c2 ifInvalid: element "Answer a submatrix [r1..r2][c1..c2] of the receiver. Portions of the result outside the bounds of the original matrix are filled in with element." |rd cd| rd _ r1 - 1. cd _ c1 - 1. ^self class rows: r2-rd columns: c2-cd tabulate: [:r :c| self at: r+rd at: c+cd ifInvalid: element] ! ! !Matrix methodsFor: 'accessing submatrices' stamp: 'raok 11/25/2002 12:32'! atRows: r1 to: r2 columns: c1 to: c2 put: aMatrix "Set the [r1..r2][c1..c2] submatrix of the receiver from the [1..r2-r1+1][1..c2-c1+1] submatrix of aMatrix. As long as aMatrix responds to at:at: and accepts arguments in the range shown, we don't care if it is bigger or even if it is a Matrix at all." |rd cd| rd _ r1 - 1. cd _ c1 - 1. r1 to: r2 do: [:r | c1 to: c2 do: [:c | self at: r at: c put: (aMatrix at: r-rd at: c-cd)]]. ^aMatrix ! ! !Matrix methodsFor: 'adding' stamp: 'raok 10/21/2002 22:53'! add: newObject self shouldNotImplement! ! !Matrix methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:01'! +* aCollection "Premultiply aCollection by self. aCollection should be an Array or Matrix. The name of this method is APL's +.x squished into Smalltalk syntax." ^aCollection preMultiplyByMatrix: self ! ! !Matrix methodsFor: 'arithmetic' stamp: 'raok 11/28/2002 14:22'! preMultiplyByArray: a "Answer a +* self where a is an Array." nrows = 1 ifFalse: [self error: 'dimensions do not conform']. ^Matrix rows: a size columns: ncols tabulate: [:row :col | (a at: row) * (contents at: col)] ! ! !Matrix methodsFor: 'arithmetic' stamp: 'raok 10/22/2002 20:02'! preMultiplyByMatrix: m "Answer m +* self where m is a Matrix." |s| nrows = m columnCount ifFalse: [self error: 'dimensions do not conform']. ^Matrix rows: m rowCount columns: ncols tabulate: [:row :col | s _ 0. 1 to: nrows do: [:k | s _ (m at: row at: k) * (self at: k at: col) + s]. s]! ! !Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 12:58'! = aMatrix ^aMatrix class == self class and: [ aMatrix rowCount = nrows and: [ aMatrix columnCount = ncols and: [ aMatrix privateContents = contents]]]! ! !Matrix methodsFor: 'comparing' stamp: 'raok 11/22/2002 13:14'! hash "I'm really not sure what would be a good hash function here. The essential thing is that it must be compatible with #=, and this satisfies that requirement." ^contents hash! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! asArray ^contents shallowCopy! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! asBag ^contents asBag! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asByteArray ^contents asByteArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asCharacterSet ^contents asCharacterSet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asFloatArray ^contents asFloatArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asIdentitySet ^contents asIdentitySet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asIntegerArray ^contents asIntegerArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asOrderedCollection ^contents asOrderedCollection! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asSet ^contents asSet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asSortedArray ^contents asSortedArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection ^contents asSortedCollection! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection: aBlock ^contents asSortedCollection: aBlock! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asWordArray ^contents asWordArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 11/22/2002 13:02'! readStream "Answer a ReadStream that returns all the elements of the receiver in some UNSPECIFIED order." ^ReadStream on: contents! ! !Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:57'! , aMatrix "Answer a new matrix having the same number of rows as the receiver and aMatrix, its columns being the columns of the receiver followed by the columns of aMatrix." |newCont newCols anArray oldCols a b c| self assert: [nrows = aMatrix rowCount]. newCont _ Array new: self size + aMatrix size. anArray _ aMatrix privateContents. oldCols _ aMatrix columnCount. newCols _ ncols + oldCols. a _ b _ c _ 1. 1 to: nrows do: [:r | newCont replaceFrom: a to: a+ncols-1 with: contents startingAt: b. newCont replaceFrom: a+ncols to: a+newCols-1 with: anArray startingAt: c. a _ a + newCols. b _ b + ncols. c _ c + oldCols]. ^self class rows: nrows columns: newCols contents: newCont ! ! !Matrix methodsFor: 'copying' stamp: 'raok 11/22/2002 12:58'! ,, aMatrix "Answer a new matrix having the same number of columns as the receiver and aMatrix, its rows being the rows of the receiver followed by the rows of aMatrix." self assert: [ncols = aMatrix columnCount]. ^self class rows: nrows + aMatrix rowCount columns: ncols contents: contents , aMatrix privateContents ! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'! copy ^self class rows: nrows columns: ncols contents: contents copy! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:07'! shallowCopy ^self class rows: nrows columns: ncols contents: contents shallowCopy! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! shuffled ^self class rows: nrows columns: ncols contents: (contents shuffled)! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! shuffledBy: aRandom ^self class rows: nrows columns: ncols contents: (contents shuffledBy: aRandom)! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:41'! collect: aBlock "Answer a new matrix with transformed elements; transformations should be independent." ^self class rows: nrows columns: ncols contents: (contents collect: aBlock)! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! difference: aCollection "Union is in because the result is always a Set. Difference and intersection are out because the result is like the receiver, and with irregular seleection that cannot be." self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:40'! do: aBlock "Pass elements to aBlock one at a time in row-major order." contents do: aBlock! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/23/2002 20:57'! indicesCollect: aBlock |r i| r _ Array new: nrows * ncols. i _ 0. 1 to: nrows do: [:row | 1 to: ncols do: [:column | r at: (i _ i+1) put: (aBlock value: row value: column)]]. ^self class rows: nrows columns: ncols contents: r! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:49'! indicesDo: aBlock 1 to: nrows do: [:row | 1 to: ncols do: [:column | aBlock value: row value: column]].! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:51'! indicesInject: start into: aBlock |current| current _ start. 1 to: nrows do: [:row | 1 to: ncols do: [:column | current _ aBlock value: current value: row value: column]]. ^current! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! intersection: aCollection "Union is in because the result is always a Set. Difference and intersection are out because the result is like the receiver, and with irregular seleection that cannot be." self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! reject: aBlock self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! select: aBlock self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/22/2002 00:15'! with: aCollection collect: aBlock "aCollection must support #at:at: and be at least as large as the receiver." ^self withIndicesCollect: [:each :row :column | aBlock value: each value: (aCollection at: row at: column)] ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:53'! with: aCollection do: aBlock "aCollection must support #at:at: and be at least as large as the receiver." self withIndicesDo: [:each :row :column | aBlock value: each value: (aCollection at: row at: column)]. ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:55'! with: aCollection inject: startingValue into: aBlock "aCollection must support #at:at: and be at least as large as the receiver." ^self withIndicesInject: startingValue into: [:value :each :row :column | aBlock value: value value: each value: (aCollection at: row at: column)]! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesCollect: aBlock |i r| i _ 0. r _ contents shallowCopy. 1 to: nrows do: [:row | 1 to: ncols do: [:column | i _ i+1. r at: i put: (aBlock value: (r at: i) value: row value: column)]]. ^self class rows: nrows columns: ncols contents: r ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesDo: aBlock |i| i _ 0. 1 to: nrows do: [:row | 1 to: ncols do: [:column | aBlock value: (contents at: (i _ i+1)) value: row value: column]]. ! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:52'! withIndicesInject: start into: aBlock |i current| i _ 0. current _ start. 1 to: nrows do: [:row | 1 to: ncols do: [:column | current _ aBlock value: current value: (contents at: (i _ i+1)) value: row value: column]]. ^current! ! !Matrix methodsFor: 'printing' stamp: 'raok 10/21/2002 23:22'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' rows: '; store: nrows; nextPutAll: ' columns: '; store: ncols; nextPutAll: ' contents: '; store: contents; nextPut: $)! ! !Matrix methodsFor: 'removing' stamp: 'raok 10/21/2002 22:54'! remove: anObject ifAbsent: anExceptionBlock self shouldNotImplement! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! identityIncludes: anObject ^contents identityIncludes: anObject! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:23'! includes: anObject ^contents includes: anObject! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! includesAllOf: aCollection ^contents includesAllOf: aCollection! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! includesAnyOf: aCollection ^contents includesAnyOf: aCollection! ! !Matrix methodsFor: 'testing' stamp: 'raok 11/22/2002 13:03'! isSequenceable "LIE so that arithmetic on matrices will work. What matters for arithmetic is not that there should be random indexing but that the structure should be stable and independent of the values of the elements. #isSequenceable is simply the wrong question to ask." ^true! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:25'! occurrencesOf: anObject ^contents occurrencesOf: anObject! ! !Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:40'! indexForRow: row andColumn: column (row between: 1 and: nrows) ifFalse: [self error: '1st subscript out of range']. (column between: 1 and: ncols) ifFalse: [self error: '2nd subscript out of range']. ^(row-1) * ncols + column! ! !Matrix methodsFor: 'private' stamp: 'raok 11/22/2002 12:56'! privateContents "Only used in #, #,, and #= so far. It used to be called #contents, but that clashes with Collection>>contents." ^contents! ! !Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 22:47'! rowAndColumnForIndex: index |t| t _ index - 1. ^(t // ncols + 1)@(t \\ ncols + 1)! ! !Matrix methodsFor: 'private' stamp: 'raok 10/21/2002 23:05'! rows: rows columns: columns contents: anArray self assert: [rows isInteger and: [rows >= 0]]. self assert: [columns isInteger and: [columns >= 0]]. self assert: [rows * columns = anArray size]. nrows _ rows. ncols _ columns. contents _ anArray. ^self! ! !Matrix commentStamp: '<historical>' prior: 0! I represent a two-dimensional array, rather like Array2D. There are three main differences between me and Array2D: (1) Array2D inherits from ArrayedCollection, but isn't one. A lot of things that should work do not work in consequence of this. (2) Array2D uses "at: column at: row" index order, which means that nothing you write using it is likely to work either. I use the almost universal "at: row at: column" order, so it is much easier to adapt code from other languages without going doolally. (3) Array2D lets you specify the class of the underlying collection, I don't. Structure: nrows : a non-negative integer saying how many rows there are. ncols : a non-negative integer saying how many columns there are. contents : an Array holding the elements in row-major order. That is, for a 2x3 array the contents are (11 12 13 21 22 23). Array2D uses column major order. You can specify the class of 'contents' when you create a new Array2D, but Matrix always gives you an Array. There is a reason for this. In strongly typed languages like Haskell and Clean, 'unboxed arrays' save you both space AND time. But in Squeak, while WordArray and FloatArray and so on do save space, it costs time to use them. A LOT of time. I've measured aFloatArray sum running nearly twice as slow as anArray sum. The reason is that whenever you fetch an element from an Array, that's all that happens, but when you fetch an element from aFloatArray, a whole new Float gets allocated to hold the value. This takes time and churns memory. So the paradox is that if you want fast numerical stuff, DON'T use unboxed arrays!! Another reason for always insisting on an Array is that letting it be something else would make things like #, and #,, rather more complicated. Always using Array is the simplest thing that could possibly work, and it works rather well. I was trying to patch Array2D to make more things work, but just couldn't get my head around the subscript order. That's why I made Matrix. Element-wise matrix arithmetic works; you can freely mix matrices and numbers but don't try to mix matrices and arrays (yet). Matrix multiplication, using the symbol +* (derived from APL's +.x), works between (Matrix or Array) +* (Matrix or Array). Don't try to use a number as an argument of +*. Matrix * Number and Number * Matrix work fine, so you don't need +* with numbers. Still to come: oodles of stuff. Gaussian elimination maybe, other stuff probably not. ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:58'! column: aCollection "Should this be called #fromColumn:?" ^self rows: aCollection size columns: 1 contents: aCollection asArray shallowCopy! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:09'! diagonal: aCollection |r i| r _ self zeros: aCollection size. i _ 0. aCollection do: [:each | i _ i+1. r at: i at: i put: each]. ^r! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! identity: n |r| r _ self zeros: n. 1 to: n do: [:i | r at: i at: i put: 1]. ^r! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:06'! new: dim "Answer a dim*dim matrix. Is this an abuse of #new:? The argument is NOT a size." ^self rows: dim columns: dim! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/25/2002 12:51'! new: dim element: element "Answer a dim*dim matrix with all elements set to element. Is this an abuse of #new:? The argument is NOT a size." ^self rows: dim columns: dim element: element! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:54'! new: dim tabulate: aBlock "Answer a dim*dim matrix where it at: i at: j is aBlock value: i value: j." ^self rows: dim columns: dim tabulate: aBlock! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:08'! ones: n ^self new: n element: 1 ! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/23/2002 20:59'! row: aCollection "Should this be called #fromRow:?" ^self rows: 1 columns: aCollection size contents: aCollection asArray shallowCopy! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 00:04'! rows: rows columns: columns ^self rows: rows columns: columns contents: (Array new: rows*columns)! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:10'! rows: rows columns: columns element: element ^self rows: rows columns: columns contents: ((Array new: rows*columns) atAllPut: element; yourself)! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 10/22/2002 19:51'! rows: rows columns: columns tabulate: aBlock "Answer a new Matrix of the given dimensions where result at: i at: j is aBlock value: i value: j" |a i| a _ Array new: rows*columns. i _ 0. 1 to: rows do: [:row | 1 to: columns do: [:column | a at: (i _ i+1) put: (aBlock value: row value: column)]]. ^self rows: rows columns: columns contents: a ! ! !Matrix class methodsFor: 'instance creation' stamp: 'raok 11/28/2002 14:09'! zeros: n ^self new: n element: 0! ! !Matrix class methodsFor: 'private' stamp: 'raok 10/21/2002 23:06'! rows: rows columns: columns contents: contents ^self new rows: rows columns: columns contents: contents! ! !MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 5/3/2001 13:02'! hash | result | <primitive: 'primitiveHashArray' module: 'FloatArrayPlugin'> result _ 0. 1 to: self size do:[:i| result _ result + (self basicAt: i) ]. ^result bitAnd: 16r1FFFFFFF! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 16:06'! byteSize ^self basicSize * self bytesPerBasicElement! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:04'! bytesPerBasicElement "Answer the number of bytes that each of my basic elements requires. In other words: self basicSize * self bytesPerBasicElement should equal the space required on disk by my variable sized representation." ^4! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 12:57'! bytesPerElement ^ 4. ! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'yo 3/6/2004 15:33'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | w b1 b2 b3 b4 | SmalltalkImage current isLittleEndian ifTrue: [ 1 to: self basicSize do: [:i | w _ self basicAt: i. b1 _ w digitAt: 1. b2 _ w digitAt: 2. b3 _ w digitAt: 3. b4 _ w digitAt: 4. w _ (b1 << 24) + (b2 << 16) + (b3 << 8) + b4. self basicAt: i put: w. ] ]. ! ! !MatrixTransform2x3 methodsFor: 'objects from disk' stamp: 'ar 8/6/2001 17:52'! writeOn: aStream aStream nextWordsPutAll: self.! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 8/26/2001 20:54'! transformDirection: aPoint "Transform aPoint from local coordinates into global coordinates" | x y | x _ (aPoint x * self a11) + (aPoint y * self a12). y _ (aPoint x * self a21) + (aPoint y * self a22). ^x @ y! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'mir 6/12/2001 15:34'! newFromStream: s "Only meant for my subclasses that are raw bits and word-like. For quick unpack form the disk." self isPointers | self isWords not ifTrue: [^ super newFromStream: s]. "super may cause an error, but will not be called." ^ s nextWordsInto: (self new: 6)! ! !MatrixTransformMorph methodsFor: 'change reporting' stamp: 'ar 11/12/2000 18:44'! invalidRect: rect from: aMorph aMorph == self ifTrue:[super invalidRect: rect from: self] ifFalse:[super invalidRect: (self transform localBoundsToGlobal: rect) from: aMorph].! ! !MatrixTransformMorph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:51'! visible: aBoolean "set the 'visible' attribute of the receiver to aBoolean" self hasExtension ifFalse: [aBoolean ifTrue: [^ self]]. self assureExtension visible: aBoolean! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'fbs 11/26/2004 10:59'! innerAngle ^ (self transform a11 @ self transform a21) degrees! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'mdr 12/19/2001 10:49'! rotateBy: delta | pt m | delta = 0.0 ifTrue:[^self]. self changed. pt _ self transformFromWorld globalPointToLocal: self referencePosition. m _ MatrixTransform2x3 withOffset: pt. m _ m composedWithLocal: (MatrixTransform2x3 withAngle: delta). m _ m composedWithLocal: (MatrixTransform2x3 withOffset: pt negated). self transform: (transform composedWithLocal: m). self changed.! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 9/11/2000 21:16'! transform ^ transform ifNil: [MatrixTransform2x3 identity]! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'mdr 12/19/2001 10:48'! boundsChangedFrom: oldBounds to: newBounds oldBounds extent = newBounds extent ifFalse:[ transform _ transform composedWithGlobal: (MatrixTransform2x3 withOffset: oldBounds origin negated). transform _ transform composedWithGlobal: (MatrixTransform2x3 withScale: newBounds extent / oldBounds extent). transform _ transform composedWithGlobal: (MatrixTransform2x3 withOffset: newBounds origin). ]. transform offset: transform offset + (newBounds origin - oldBounds origin)! ! !MatrixTransformMorph methodsFor: 'geometry' stamp: 'ar 6/12/2001 06:18'! computeBounds | subBounds box | (submorphs isNil or:[submorphs isEmpty]) ifTrue:[^self]. box _ nil. submorphs do:[:m| subBounds _ self transform localBoundsToGlobal: m bounds. box ifNil:[box _ subBounds] ifNotNil:[box _ box quickMerge: subBounds]. ]. box ifNil:[box _ 0@0 corner: 20@20]. fullBounds _ bounds _ box! ! !MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 06:03'! heading "Return the receiver's heading (in eToy terms)" ^ self forwardDirection + self innerAngle! ! !MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 06:03'! heading: newHeading "Set the receiver's heading (in eToy terms)" self rotateBy: ((newHeading - self forwardDirection) - self innerAngle).! ! !MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:11'! rotationCenter | pt | pt _ self transform localPointToGlobal: super rotationCenter. ^pt - bounds origin / bounds extent asFloatPoint! ! !MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:07'! rotationCenter: aPoint super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))! ! !MatrixTransformMorph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:50'! setDirectionFrom: aPoint | delta degrees | delta _ (self transformFromWorld globalPointToLocal: aPoint) - super rotationCenter. degrees _ delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !MatrixTransformMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:38'! initialize "initialize the state of the receiver" super initialize. "" transform _ MatrixTransform2x3 identity! ! !MatrixTransformMorph methodsFor: 'menus' stamp: 'jcg 11/1/2001 13:03'! setRotationCenterFrom: aPoint super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint) ! ! !MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'! privateFullMoveBy: delta self privateMoveBy: delta. transform offset: transform offset + delta.! ! !MatrixTransformMorph commentStamp: '<historical>' prior: 0! MatrixTransformMorph is similar to TransformMorph but uses a MatrixTransform2x3 instead of a MorphicTransform. It is used by clients who want use the BalloonEngine for vector-based scaling instead of the standard WarpBlt pixel-based mechanism.! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 11:13'! associate: tokens | result | result _ Dictionary new. tokens pairsDo: [:key :value | value isString ifFalse: [value _ value collect: [:ea | self associate: ea]]. value = 'nil' ifTrue: [value _ '']. result at: key put: value]. ^ result! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:53'! checkDependencies | dependencies unmet | dependencies _ (zip membersMatching: 'dependencies/*') collect: [:member | self extractInfoFrom: (self parseMember: member)]. unmet _ dependencies reject: [:dep | self versions: Versions anySatisfy: (dep at: #id)]. ^ unmet isEmpty or: [ self confirm: (String streamContents: [:s| s nextPutAll: 'The following dependencies seem to be missing:'; cr. unmet do: [:each | s nextPutAll: (each at: #name); cr]. s nextPutAll: 'Do you still want to install this package?'])]! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 03:26'! extractInfoFrom: dict dict at: #id put: (UUID fromString: (dict at: #id)). dict at: #date ifPresent: [:d | d isEmpty ifFalse: [dict at: #date put: (Date fromString: d)]]. dict at: #time ifPresent: [:t | t isEmpty ifFalse: [dict at: #time put: (Time readFrom: t readStream)]]. dict at: #ancestors ifPresent: [:a | dict at: #ancestors put: (a collect: [:ea | self extractInfoFrom: ea])]. ^ dict! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58'! extractPackageName ^ (self parseMember: 'package') at: #name. ! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:17'! extractVersionInfo ^ self extractInfoFrom: (self parseMember: 'version')! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:56'! install | sources | zip _ ZipArchive new. zip readFrom: stream. self checkDependencies ifFalse: [^false]. self recordVersionInfo. sources _ (zip membersMatching: 'snapshot/*') asSortedCollection: [:a :b | a fileName < b fileName]. sources do: [:src | self installMember: src].! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'yo 8/17/2004 10:03'! installMember: member | str | self useNewChangeSetDuring: [str _ member contentStream text. str setConverterForCode. str fileInAnnouncing: 'loading ', member fileName]! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 01:58'! parseMember: fileName | tokens | tokens _ (self scanner scanTokens: (zip contentsOf: fileName)) first. ^ self associate: tokens! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/7/2003 19:18'! recordVersionInfo Versions at: self extractPackageName put: self extractVersionInfo! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'cwp 8/13/2003 02:04'! scanner ^ Scanner new! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:55'! stream: aStream stream _ aStream! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'bf 2/9/2004 13:56'! useNewChangeSetDuring: aBlock | changeHolder oldChanges newChanges | changeHolder _ (ChangeSet respondsTo: #newChanges:) ifTrue: [ChangeSet] ifFalse: [Smalltalk]. oldChanges _ (ChangeSet respondsTo: #current) ifTrue: [ChangeSet current] ifFalse: [Smalltalk changes]. newChanges _ ChangeSet new name: (ChangeSet uniqueNameLike: self extractPackageName). changeHolder newChanges: newChanges. [aBlock value] ensure: [changeHolder newChanges: oldChanges].! ! !MczInstaller methodsFor: 'as yet unclassified' stamp: 'bf 2/9/2004 15:00'! versions: aVersionList anySatisfy: aDependencyID ^ aVersionList anySatisfy: [:version | aDependencyID = (version at: #id) or: [self versions: (version at: #ancestors) anySatisfy: aDependencyID]]! ! !MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:49'! extension ^ 'mcz'! ! !MczInstaller class methodsFor: 'services' stamp: 'nk 6/8/2004 17:29'! fileReaderServicesForFile: fileName suffix: suffix ^({ self extension. '*' } includes: suffix) ifTrue: [ self services ] ifFalse: [#()]. ! ! !MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:51'! initialize self clearVersionInfo. self registerForFileList.! ! !MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:54'! loadVersionFile: fileName self installFileNamed: fileName ! ! !MczInstaller class methodsFor: 'services' stamp: 'avi 3/7/2004 14:49'! registerForFileList Smalltalk at: #MCReader ifAbsent: [FileList registerFileReader: self]! ! !MczInstaller class methodsFor: 'services' stamp: 'cwp 8/7/2003 18:53'! serviceLoadVersion ^ SimpleServiceEntry provider: self label: 'load' selector: #loadVersionFile: description: 'load a package version'! ! !MczInstaller class methodsFor: 'services' stamp: 'ab 8/8/2003 18:01'! services ^ Array with: self serviceLoadVersion! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 18:13'! installFileNamed: aFileName self installStream: (FileStream readOnlyFileNamed: aFileName)! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 17:56'! installStream: aStream (self on: aStream) install! ! !MczInstaller class methodsFor: 'instance creation' stamp: 'cwp 8/7/2003 17:56'! on: aStream ^ self new stream: aStream! ! !MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 1/19/2004 13:13'! clearVersionInfo Versions _ Dictionary new! ! !MczInstaller class methodsFor: 'versionInfo' stamp: 'cwp 8/11/2003 23:49'! storeVersionInfo: aVersion Versions at: aVersion package name put: aVersion info asDictionary! ! !MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 3/7/2004 14:51'! unloadMonticello "self unloadMonticello" Utilities breakDependents. Smalltalk at: #MCWorkingCopy ifPresent: [:wc | wc allInstances do: [:ea | Versions at: ea package name put: ea currentVersionInfo asDictionary. ea breakDependents. Smalltalk at: #SystemChangeNotifier ifPresent: [:scn | scn uniqueInstance noMoreNotificationsFor: ea]] displayingProgress: 'Saving version info...']. "keep things simple and don't unload any class extensions" (ChangeSet superclassOrder: ((PackageInfo named: 'Monticello') classes)) reverseDo: [:ea | ea removeFromSystem]. self registerForFileList.! ! !MczInstaller class methodsFor: 'versionInfo' stamp: 'avi 2/17/2004 02:49'! versionInfo ^ Versions! ! !MenuIcons commentStamp: 'sd 11/9/2003 14:09' prior: 0! I represent a registry for icons. You can see the icons I contain using the following script: | dict methods | dict := Dictionary new. methods := MenuIcons class selectors select: [:each | '*Icon' match: each asString]. methods do: [:each | dict at: each put: (MenuIcons perform: each)]. GraphicalDictionaryMenu openOn: dict withLabel: 'MenuIcons'! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! appearanceIcon ^ Icons at: #appearanceIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 4294967295 4294914610 1261581055 4294967295 4294967078 623850055 1262304536 553648127 4294914607 1412644660 1442878037 789774335 4280635289 328705 963542642 2571702015 4282131736 1176307975 1432640097 1586838527 993792806 224354447 2407892317 1603437837 1247750183 1015843973 2340717698 1989375523 1318556043 2340714370 2004316529 2140372782 407732874 2172024433 1532717146 1752262444 4279898433 2172025179 1751672644 976899103 4294967059 744184680 1532783892 33756182 4294967295 322984808 1129334839 101063935 4294967295 4279068775 757801555 1666714879 4294967295 4294909784 1498567000 1461059583 4294967295 4294967053 371085598 184549375 4294967295 4294967295 169221642 4294967295) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.129 0.646 1.0) #(0.129 0.905 0.223) #(0.129 0.968 0.258) #(0.16 0.71 1.0) #(0.258 0.678 1.0) #(0.258 0.905 0.129) #(0.289 0.741 0.905) #(0.289 0.87 0.094) #(0.321 0.807 0.968) #(0.419 0.258 0.16) #(0.419 0.548 0.0) #(0.451 0.223 0.063) #(0.451 0.289 0.16) #(0.451 0.321 0.223) #(0.482 0.289 0.129) #(0.482 0.289 0.16) #(0.482 0.321 0.16) #(0.482 0.353 0.258) #(0.482 0.388 0.289) #(0.482 0.548 0.0) #(0.517 0.223 0.031) #(0.517 0.258 0.063) #(0.517 0.258 0.094) #(0.517 0.353 0.192) #(0.517 0.353 0.223) #(0.517 0.388 0.321) #(0.548 0.258 0.031) #(0.548 0.419 0.0) #(0.548 0.839 0.839) #(0.58 0.258 0.031) #(0.58 0.289 0.063) #(0.58 0.482 0.388) #(0.611 0.289 0.031) #(0.611 0.321 0.968) #(0.646 0.258 0.031) #(0.646 0.321 0.063) #(0.646 0.451 0.258) #(0.646 0.548 0.451) #(0.678 0.419 0.16) #(0.678 0.451 0.16) #(0.678 0.451 0.258) #(0.678 0.482 0.321) #(0.678 0.482 1.0) #(0.71 0.353 0.031) #(0.71 0.353 0.678) #(0.71 0.388 0.063) #(0.71 0.451 0.192) #(0.71 0.451 0.223) #(0.71 0.482 0.223) #(0.71 0.482 0.321) #(0.71 0.807 0.936) #(0.71 0.87 1.0) #(0.741 0.388 0.063) #(0.741 0.451 0.192) #(0.741 0.482 0.031) #(0.741 0.482 0.223) #(0.741 0.807 0.807) #(0.741 0.839 0.58) #(0.776 0.482 0.192) #(0.776 0.548 0.223) #(0.776 0.548 0.321) #(0.776 0.87 0.678) #(0.776 0.905 1.0) #(0.807 0.451 0.063) #(0.807 0.482 0.129) #(0.807 0.517 0.192) #(0.807 0.517 0.611) #(0.807 0.548 0.031) #(0.807 0.58 0.258) #(0.807 0.58 0.321) #(0.807 0.611 0.388) #(0.839 0.58 0.87) #(0.839 0.611 0.353) #(0.839 0.646 0.289) #(0.839 0.646 0.419) #(0.87 0.548 0.063) #(0.87 0.58 0.16) #(0.87 0.58 0.192) #(0.87 0.646 0.353) #(0.87 0.776 1.0) #(0.905 0.451 0.223) #(0.905 0.611 0.517) #(0.936 0.388 0.031) #(0.936 0.807 0.646) #(0.936 0.87 0.71) #(0.936 1.0 1.0) #(0.968 0.419 0.0) #(0.968 0.482 0.0) #(0.968 0.482 0.129) #(0.968 0.611 0.129) #(0.968 0.646 0.16) #(0.968 0.678 0.419) #(0.968 0.741 0.388) #(0.968 0.839 0.678) #(0.968 0.87 0.517) #(0.968 0.905 0.646) #(1.0 0.451 0.063) #(1.0 0.482 0.0) #(1.0 0.517 0.0) #(1.0 0.517 0.129) #(1.0 0.548 0.031) #(1.0 0.548 0.063) #(1.0 0.58 0.031) #(1.0 0.58 0.063) #(1.0 0.58 0.094) #(1.0 0.58 0.129) #(1.0 0.611 0.094) #(1.0 0.611 0.16) #(1.0 0.611 0.192) #(1.0 0.611 0.419) #(1.0 0.646 0.129) #(1.0 0.646 0.16) #(1.0 0.646 0.223) #(1.0 0.646 0.482) #(1.0 0.678 0.16) #(1.0 0.678 0.192) #(1.0 0.678 0.223) #(1.0 0.71 0.223) #(1.0 0.71 0.258) #(1.0 0.741 0.063) #(1.0 0.741 0.16) #(1.0 0.741 0.258) #(1.0 0.741 0.289) #(1.0 0.741 0.321) #(1.0 0.741 0.353) #(1.0 0.741 0.58) #(1.0 0.776 0.063) #(1.0 0.776 0.16) #(1.0 0.776 0.289) #(1.0 0.776 0.321) #(1.0 0.776 0.353) #(1.0 0.776 0.419) #(1.0 0.776 0.451) #(1.0 0.776 0.517) #(1.0 0.807 0.419) #(1.0 0.807 0.451) #(1.0 0.807 0.548) #(1.0 0.839 0.353) #(1.0 0.839 0.388) #(1.0 0.839 0.451) #(1.0 0.839 0.482) #(1.0 0.87 0.517) #(1.0 0.87 0.58) #(1.0 0.87 0.678) #(1.0 0.905 0.451) #(1.0 0.905 0.87) #(1.0 0.936 0.192) #(1.0 0.936 0.321) #(1.0 0.936 0.741) #(1.0 0.936 0.807) #(1.0 0.968 0.548) #(1.0 0.968 0.87) #(1.0 1.0 0.905) #(1.0 1.0 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! backAndForthIcon ^ Icons at: #backAndForthIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1583242846 1577189890 33686110 1583242846 1583242754 34081804 202115074 39738974 1583219208 202116108 202116108 134372958 1577191430 201656588 202114314 151519838 1577192460 173803788 202136581 168362590 34081802 1549535498 202136668 84543746 34343429 1549534556 1549556828 1543834114 34211164 1549556828 1549556828 1549536257 39607388 1549556828 1549556828 1549556737 34233436 1543832837 89939036 1549535745 34343516 1549535497 151608412 1544162306 1577192458 1549535500 202136668 168559198 1577191436 173803788 202136586 201851486 1583219208 202116108 201721356 134372958 1583242754 34081804 202115074 39738974 1583242846 4278321666 33686110 1583242846) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! backIcon ^ Icons at: #backIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 538976288 537002498 33686048 538976288 538976258 34081804 202115074 35659808 538968584 202116108 202116108 134357024 537004038 201655561 202116108 201851424 537005068 168123401 202116108 202113568 34081802 89938953 202116108 202116098 34343429 1549556828 1549556828 84216834 34211164 1549556828 1549556828 1543833857 33905756 1549556828 1549556828 1543833857 34145628 1543832837 89939036 84216065 34343173 1549556745 151587081 151389186 537005065 89938953 202116102 100925984 537004044 151346185 202116102 101188128 538968584 201918729 201721348 134357024 538976258 34081804 202115074 35659808 538976288 537002498 33686048 538976288) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #( ) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'nk 3/9/2004 11:27'! blankIcon ^ Icons at: #blankIcon ifAbsentPut: [ Form extent: 16 @ 16 depth: 8 ] ! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! cancelIcon ^ Icons at: #cancelIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447663 791551247 190733918 1583223839 978802495 1060514107 419978846 1578179663 1415001600 3552809 1377306974 1578448975 909522432 3552822 691604062 287324214 909522432 3552822 910693895 322450998 909522432 3552822 909517061 305415734 1161184512 3552822 690562052 255017795 1128477440 3552809 690562052 271139394 1111631168 3552051 859971842 236864066 1111634772 1396851266 1111627014 1578054466 1111634723 759317058 1110639710 1577784644 1145251905 4932420 1141637982 1583220758 893798231 1464419893 218193502 1583242761 169552695 925243140 56516190 1583242846 1577518340 67241566 1583242846) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! copyIcon ^ Icons at: #copyIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 186325787 454761243 454043945 690563369 402653184 0 2360874 690563369 402653184 639968549 622923050 690563369 402653208 404232216 404232216 403253545 402653207 654311424 0 2294825 402653207 654311424 0 656609066 402663191 654311424 2565926 555814186 405218836 654311424 656877089 555813418 405020946 637534247 656810273 538970666 337715473 637544231 606150944 538839082 253829134 640099874 555819040 505219114 34212354 606478625 555753246 488376106 707406338 589373729 538910237 471467818 690563330 539041824 522066972 437847338 690563330 252641794 33686018 33685802 690563370 707406378 707406378 707406378) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.678 0.87) #(0.482 0.71 0.936) #(0.517 0.548 0.58) #(0.517 0.611 0.741) #(0.517 0.71 0.87) #(0.548 0.71 0.87) #(0.548 0.71 0.905) #(0.58 0.741 0.905) #(0.611 0.678 0.776) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.548 0.482) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.646 0.807 0.968) #(0.678 0.776 0.87) #(0.678 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.807 0.905) #(0.71 0.839 0.968) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.87 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! cutIcon ^ Icons at: #cutIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 169285399 387389207 387389207 251935804 321990961 825307441 825307440 823263548 321990969 825307441 825309481 2623293 321992755 925970737 825701166 2559037 321993266 876032305 926167590 589499453 321990970 842282807 875701795 589499197 321990961 976434485 707142435 589498685 321990961 824981046 740500259 505350461 321990961 758524715 908402462 505284669 321990958 925573666 725032988 505153341 321990455 723657503 489371425 505087805 321987108 572465950 471475225 504890941 254357760 2302750 505290270 504890685 237187363 522133020 454563861 336855869 235670540 202115337 117901061 83951933 238894397 1027423549 1027423549 1027423549) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.58 0.646) #(0.517 0.678 0.87) #(0.517 0.71 0.87) #(0.548 0.58 0.646) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.611 0.776 0.905) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.839 0.968) #(0.71 0.87 1.0) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.839 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.87 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.678 0.741) #(0.839 0.71 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.71 0.776) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.388 0.419) #(0.905 0.388 0.451) #(0.905 0.741 0.776) #(0.905 0.936 0.968) #(0.936 0.223 0.289) #(0.936 0.388 0.419) #(0.936 0.741 0.776) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.223 0.289) #(0.968 0.289 0.321) #(0.968 0.321 0.388) #(0.968 0.388 0.451) #(0.968 0.419 0.451) #(0.968 0.451 0.482) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.192 0.258) #(1.0 0.223 0.289) #(1.0 0.223 0.321) #(1.0 0.289 0.353) #(1.0 0.353 0.388) #(1.0 0.388 0.419) #(1.0 0.419 0.482) #(1.0 0.58 0.611) #(1.0 0.776 0.807) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! deleteIcon ^ Icons at: #deleteIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 169285399 387389207 387389207 251935804 321990961 825307441 825307440 823263548 321990969 825307441 825309481 2623293 321992755 925970737 825701166 2559037 321993266 876032305 926167590 589499453 321990970 842282807 875701795 589499197 321990961 976434485 707142435 589498685 321990961 824981046 740500259 505350461 321990961 758524715 908402462 505284669 321990958 925573666 725032988 505153341 321990455 723657503 489371425 505087805 321987108 572465950 471475225 504890941 254357760 2302750 505290270 504890685 237187363 522133020 454563861 336855869 235670540 202115337 117901061 83951933 238894397 1027423549 1027423549 1027423549) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.482 0.58 0.646) #(0.517 0.678 0.87) #(0.517 0.71 0.87) #(0.548 0.58 0.646) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.611 0.776 0.905) #(0.611 0.776 0.936) #(0.611 0.839 1.0) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.807 0.968) #(0.71 0.839 0.968) #(0.71 0.87 1.0) #(0.741 0.807 0.905) #(0.741 0.839 0.905) #(0.741 0.839 0.968) #(0.741 0.87 1.0) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.776 0.87 0.936) #(0.776 0.936 1.0) #(0.807 0.87 0.936) #(0.839 0.678 0.741) #(0.839 0.71 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.71 0.776) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.388 0.419) #(0.905 0.388 0.451) #(0.905 0.741 0.776) #(0.905 0.936 0.968) #(0.936 0.223 0.289) #(0.936 0.388 0.419) #(0.936 0.741 0.776) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.936 0.968 1.0) #(0.968 0.223 0.289) #(0.968 0.289 0.321) #(0.968 0.321 0.388) #(0.968 0.388 0.451) #(0.968 0.419 0.451) #(0.968 0.451 0.482) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.192 0.258) #(1.0 0.223 0.289) #(1.0 0.223 0.321) #(1.0 0.289 0.353) #(1.0 0.353 0.388) #(1.0 0.388 0.419) #(1.0 0.419 0.482) #(1.0 0.58 0.611) #(1.0 0.776 0.807) #(0.0 0.0 0.0) #( ) #(0.258 0.396 0.451) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! doItIcon ^ Icons at: #doItIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1229539657 1229539657 235144196 68030025 1229539657 1229539585 524502844 791489806 1229539657 1225658690 1144335919 705954377 1229539598 238634555 841887258 50612553 1225656876 1144862257 739968782 1229539657 237518392 825307441 857474318 1229539657 1224806177 775958834 876364589 487344457 1229539598 235282994 825241134 672352585 1229539598 238107185 825172752 21580105 1225657153 1162164017 420023881 1229539657 237453106 741421363 924258830 1229539657 1224806692 741093681 825310761 340347209 1229539585 724709678 622002958 1229539657 1225592127 942085638 17058121 1229539657 222182944 218173001 1229539657 1229539657 219152654 1229539657 1229539657 1229539657) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.031 0.031 0.0) #(0.063 0.063 0.0) #(0.094 0.063 0.0) #(0.094 0.094 0.063) #(0.129 0.094 0.0) #(0.129 0.129 0.0) #(0.129 0.129 0.094) #(0.16 0.129 0.0) #(0.16 0.16 0.0) #(0.192 0.192 0.0) #(0.192 0.192 0.129) #(0.223 0.192 0.0) #(0.258 0.223 0.0) #(0.258 0.258 0.0) #(0.289 0.289 0.0) #(0.353 0.321 0.0) #(0.353 0.321 0.223) #(0.419 0.388 0.0) #(0.482 0.451 0.0) #(0.517 0.451 0.063) #(0.517 0.482 0.0) #(0.517 0.517 0.192) #(0.517 0.517 0.223) #(0.611 0.548 0.063) #(0.611 0.58 0.0) #(0.646 0.611 0.031) #(0.646 0.611 0.16) #(0.646 0.611 0.192) #(0.678 0.611 0.0) #(0.678 0.646 0.0) #(0.71 0.646 0.0) #(0.71 0.678 0.0) #(0.776 0.71 0.063) #(0.807 0.741 0.0) #(0.807 0.741 0.031) #(0.807 0.776 0.0) #(0.839 0.839 0.094) #(0.87 0.807 0.0) #(0.905 0.839 0.0) #(0.936 0.87 0.0) #(0.968 0.87 0.031) #(0.968 0.905 0.063) #(1.0 0.905 0.063) #(1.0 0.936 0.0) #(1.0 0.936 0.063) #(1.0 0.936 0.094) #(1.0 0.936 0.129) #(1.0 0.936 0.16) #(1.0 0.936 0.192) #(1.0 0.936 0.223) #(1.0 0.936 0.258) #(1.0 0.936 0.289) #(1.0 0.936 0.321) #(1.0 0.936 0.353) #(1.0 0.968 0.129) #(1.0 0.968 0.223) #(1.0 0.968 0.289) #(1.0 0.968 0.482) #(1.0 0.968 0.517) #(1.0 0.968 0.548) #(1.0 1.0 0.0) #(1.0 1.0 0.031) #(1.0 1.0 0.094) #(1.0 1.0 0.192) #(1.0 1.0 0.321) #(1.0 1.0 0.517) #(1.0 1.0 0.58) #(1.0 1.0 0.611) #(1.0 1.0 0.646) #(1.0 1.0 0.71) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! findIcon ^ Icons at: #findIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 286331153 286331153 286331153 286331153 285278481 286331153 286331153 286331153 17762561 286331137 17895697 286331153 17368321 286327055 151064849 286331153 285278481 286327049 83955985 286331153 286331153 286331137 17895697 286331153 286331153 286331153 286331153 16847121 286327041 16847121 286331137 252248337 285278222 218890513 286331137 151322897 285281805 201918209 286331153 16847121 285281548 151521025 286331153 286331153 285281289 134678017 286331153 286331153 285280520 117834753 286331137 17895697 285280263 100926209 286327055 151064849 286327041 16843025 286327049 83955985 286331153 286331153 286331138 17895697) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.16 0.223 0.289) #(0.388 0.611 0.839) #(0.419 0.646 0.839) #(0.482 0.646 0.87) #(0.482 0.678 0.87) #(0.548 0.71 0.87) #(0.611 0.741 0.905) #(0.646 0.776 0.905) #(0.678 0.678 0.678) #(0.678 0.776 0.905) #(0.71 0.807 0.905) #(0.741 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.905 0.968) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! forwardIcon ^ Icons at: #forwardIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 555819297 553779714 33686049 555819297 555819266 34081804 202115074 35725601 555811336 202116108 202116108 134357281 553781254 202116108 151323916 151519777 553782284 202116108 157047813 201916961 34081798 101058054 157047900 84674818 34343429 1543832837 1549556828 1543834626 34211164 1549556828 1549556828 1549534465 39607388 1549556828 1549556828 1549556737 34233436 1543832837 89939036 1543833857 34343177 151587081 157047900 84478978 553782284 202116108 157047813 151781921 553781260 202116108 157025545 201851425 555811336 202116108 201918732 134357281 555819266 34081804 202115074 35725601 555819297 553779714 33686049 555819297) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #(0.0 0.501 1.0) #(0.4 1.0 0.8) #(0.804 1.0 0.921) #(0.145 1.0 0.725) #(0.317 1.0 0.792) #(0.38 0.591 0.674) #(0.423 0.678 0.772) #(0.69 1.0 0.878) #(0.431 0.706 0.835) #(0.117 0.878 0.646) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #( ) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(0.301 1.0 0.289) #(0.478 1.0 0.388) #(0.349 1.0 0.282) #(0.435 1.0 0.223) #(0.451 1.0 0.674) #(0.634 1.0 0.584) #(0.333 1.0 0.246) #(0.607 1.0 0.455) #(0.207 1.0 0.203) #(0.357 1.0 0.274) #(0.211 1.0 0.282) #(0.564 1.0 0.541) #(0.721 1.0 0.584) #(0.439 1.0 0.447) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(0.4 0.365 1.0) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! helpIcon ^ Icons at: #helpIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447663 791551247 190733918 1583223839 978796095 1062687035 419978846 1578179663 1413307392 23896 1377306974 1578448976 805306453 1381564503 1362692702 287329870 1006655054 1278148608 1279792647 321538890 1314016584 657588310 690561285 305415749 1162167596 1040210997 690562052 255017795 1128477489 5780777 690562052 271139394 1111631168 3552051 859971842 236864066 1111634772 1396851266 1111627014 1578054466 1111634723 759317058 1110639710 1577784644 1145251905 4932420 1141637982 1583220758 893798231 1464419893 218193502 1583242761 169552695 925243140 56516190 1583242846 1577518340 67241566 1583242846) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! inspectIcon ^ Icons at: #inspectIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 656877313 16843009 656877351 656877351 656867609 589306902 19343143 656877351 654385957 538909463 352397095 656877351 18425121 504895255 386990375 656877351 19013662 387257620 336462119 656877351 18816279 353571603 235536679 656877351 18487317 320017166 236388647 656877351 17830931 319753742 236388647 656877351 654381587 252579086 402719271 656877351 656867594 235738903 16908545 656877351 656877313 16843009 33621512 19343143 656877351 656877351 654379046 134293287 656877351 656877351 656867591 638124327 656877351 656877351 656877313 136578049 656877351 656877351 656877351 16974337 656877351 656877351 656877351 654377255) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.388 0.321 0.258) #(0.482 0.353 0.223) #(0.482 0.388 0.321) #(0.517 0.678 0.839) #(0.548 0.321 0.16) #(0.548 0.353 0.192) #(0.548 0.388 0.258) #(0.548 0.451 0.388) #(0.548 0.678 0.807) #(0.548 0.71 0.87) #(0.548 0.71 0.905) #(0.548 0.741 0.905) #(0.58 0.741 0.905) #(0.58 0.776 0.905) #(0.611 0.71 0.776) #(0.611 0.71 0.807) #(0.611 0.776 0.87) #(0.611 0.776 0.905) #(0.646 0.776 0.905) #(0.646 0.807 0.905) #(0.678 0.741 0.807) #(0.678 0.807 0.905) #(0.71 0.839 0.936) #(0.776 0.807 0.807) #(0.776 0.839 0.905) #(0.776 0.87 0.936) #(0.807 0.87 0.905) #(0.807 0.87 0.936) #(0.807 0.905 0.936) #(0.839 0.905 0.968) #(0.87 0.905 0.968) #(0.87 0.936 0.968) #(0.905 0.936 0.936) #(0.905 0.936 0.968) #(0.936 0.678 0.451) #(0.936 0.968 0.968) #(0.968 0.71 0.482) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! morphsIcon ^ Icons at: #morphsIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 4294926691 1677721599 4294967098 989855743 4284899437 1835401215 4294916662 942014463 1667457633 1634232831 4282005299 909846015 1667589734 1583311711 976829247 1162100773 1667524199 1717529439 976898895 1330594085 4285099111 1600061439 4282006863 1515136511 4294929259 1811939327 4294916670 1311113215 4294967077 637534207 4294967098 637534207 4294967077 637534207 4294913577 690946047 4294967077 637534207 4281227101 1548495359 4294911274 757465087 777082706 1381123921 4294911292 992346111 1230591059 1280134217 4280632907 1211966975 1230394195 1363954761 4280635477 1430924543 4284175958 1280066303 625956954 1481590821 4281422163 1363945983 625956952 1481590821 4294967116 1291845631) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.031 0.031 0.031) #(0.031 0.031 0.063) #(0.031 0.063 0.094) #(0.031 0.094 0.16) #(0.063 0.031 0.063) #(0.063 0.063 0.094) #(0.063 0.063 0.129) #(0.063 0.094 0.129) #(0.094 0.063 0.094) #(0.094 0.094 0.063) #(0.094 0.094 0.094) #(0.094 0.094 0.129) #(0.094 0.129 0.223) #(0.129 0.0 0.0) #(0.129 0.031 0.031) #(0.129 0.094 0.094) #(0.129 0.129 0.16) #(0.129 0.192 0.258) #(0.129 0.192 0.321) #(0.16 0.0 0.0) #(0.16 0.129 0.129) #(0.16 0.16 0.0) #(0.16 0.223 0.321) #(0.192 0.0 0.0) #(0.192 0.16 0.16) #(0.192 0.192 0.0) #(0.192 0.258 0.321) #(0.192 0.321 0.548) #(0.223 0.192 0.0) #(0.223 0.223 0.0) #(0.223 0.258 0.353) #(0.223 0.289 0.419) #(0.258 0.16 0.16) #(0.258 0.223 0.0) #(0.258 0.321 0.451) #(0.258 0.388 0.611) #(0.289 0.289 0.0) #(0.289 0.353 0.419) #(0.289 0.353 0.451) #(0.353 0.16 0.16) #(0.388 0.548 0.807) #(0.419 0.548 0.776) #(0.419 0.58 0.741) #(0.419 0.58 0.839) #(0.451 0.0 0.0) #(0.451 0.451 0.16) #(0.451 0.451 0.223) #(0.482 0.0 0.0) #(0.482 0.482 0.223) #(0.482 0.611 0.807) #(0.517 0.517 0.223) #(0.517 0.646 0.839) #(0.548 0.678 0.839) #(0.548 0.678 0.87) #(0.548 0.678 0.905) #(0.548 0.71 0.968) #(0.548 0.741 1.0) #(0.58 0.741 0.905) #(0.58 0.741 0.936) #(0.58 0.741 1.0) #(0.611 0.776 1.0) #(0.646 0.807 0.905) #(0.646 0.807 1.0) #(0.646 0.839 1.0) #(0.678 0.0 0.0) #(0.678 0.646 0.129) #(0.678 0.807 0.936) #(0.678 0.839 0.936) #(0.678 0.839 1.0) #(0.71 0.0 0.0) #(0.71 0.87 1.0) #(0.741 0.0 0.0) #(0.741 0.905 1.0) #(0.776 0.936 1.0) #(0.807 0.0 0.0) #(0.807 0.063 0.063) #(0.807 0.936 1.0) #(0.807 0.968 1.0) #(0.807 1.0 1.0) #(0.839 0.0 0.0) #(0.839 0.289 0.289) #(0.87 0.0 0.0) #(0.87 0.031 0.031) #(0.87 1.0 1.0) #(0.905 0.0 0.0) #(0.905 0.388 0.388) #(0.905 1.0 1.0) #(0.936 0.063 0.063) #(0.936 1.0 1.0) #(0.968 0.0 0.0) #(0.968 0.741 0.71) #(1.0 0.776 0.776) #(1.0 0.936 0.16) #(1.0 0.936 0.192) #(1.0 0.936 0.289) #(1.0 0.936 0.353) #(1.0 0.936 0.388) #(1.0 0.968 0.0) #(1.0 0.968 0.129) #(1.0 0.968 0.16) #(1.0 0.968 0.192) #(1.0 0.968 0.223) #(1.0 0.968 0.419) #(1.0 1.0 0.0) #(1.0 1.0 0.063) #(1.0 1.0 0.094) #(1.0 1.0 0.223) #(1.0 1.0 0.741) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:50'! newIcon ^ Icons at: #newIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 421075227 454761242 437918232 404232217 421075227 269488144 269484048 269490199 421075227 269488144 269484048 269490199 420354318 336465166 403505165 218961943 236196115 336793876 236453897 151590935 420549650 353506321 403179528 134748183 236130837 353702419 236455173 84219927 336860437 353703188 337118212 67377175 236130837 353702419 236455173 84219927 420353042 353506321 386402312 134682647 236195345 336662036 236388361 134813719 420354062 336467982 386596875 185276439 421075223 404229912 252641295 252647447 421075224 218959117 218959117 218961943 421075224 404232216 404232216 404232215 421075225 387389207 387389207 387389207) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.129 0.129 0.129) #(0.192 0.192 0.192) #(0.776 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.905 0.936) #(0.839 0.905 0.968) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.936 0.936) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.58 0.094) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.646 0.0) #(1.0 0.807 0.0) #(1.0 0.87 0.0) #(1.0 1.0 0.0) #(1.0 1.0 0.776) #(0.0 0.0 0.0) #(0.258 0.396 0.451) #(0.321 0.494 0.56) #( ) #(0.345 0.529 0.603) #(0.47 0.721 0.823) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! okIcon ^ Icons at: #okIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 909522486 908273718 909522486 909522486 909522486 624104246 909522486 909522486 909522470 722538294 909522486 909522486 909519405 286327094 909519147 120993334 908734226 318846518 908205876 221656630 657199637 37107254 906760737 288765476 789844740 909522486 906696477 775303728 336921654 909522486 906632220 825570066 352663094 909522486 906565658 505419285 137770550 909522486 906369048 454564101 909522486 909522486 906039576 471401526 909522486 909522486 909509390 268580406 909522486 909522486 909522467 590755382 909522486 909522486) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.0 0.031 0.0) #(0.0 0.063 0.0) #(0.0 0.094 0.0) #(0.0 0.129 0.031) #(0.0 0.129 0.063) #(0.0 0.16 0.0) #(0.0 0.16 0.031) #(0.0 0.192 0.063) #(0.0 0.258 0.031) #(0.0 0.321 0.031) #(0.0 0.321 0.063) #(0.0 0.388 0.0) #(0.0 0.482 0.129) #(0.0 0.58 0.129) #(0.0 0.611 0.192) #(0.0 0.646 0.129) #(0.0 0.678 0.129) #(0.0 0.678 0.16) #(0.0 0.71 0.129) #(0.0 0.71 0.16) #(0.0 0.741 0.094) #(0.0 0.741 0.129) #(0.0 0.741 0.16) #(0.0 0.741 0.192) #(0.0 0.776 0.129) #(0.0 0.807 0.129) #(0.0 0.807 0.16) #(0.031 0.741 0.16) #(0.031 0.807 0.192) #(0.063 0.646 0.223) #(0.063 0.776 0.192) #(0.094 0.71 0.192) #(0.129 0.129 0.129) #(0.129 0.16 0.129) #(0.129 0.388 0.223) #(0.16 0.289 0.192) #(0.16 0.321 0.223) #(0.16 0.419 0.223) #(0.16 0.611 0.289) #(0.192 0.289 0.223) #(0.192 0.388 0.258) #(0.192 0.646 0.321) #(0.258 0.71 0.419) #(0.258 0.741 0.388) #(0.258 0.87 0.419) #(0.289 0.741 0.388) #(0.388 0.807 0.482) #(0.388 0.905 0.482) #(0.482 0.548 0.517) #(0.58 0.905 0.646) #(0.678 0.905 0.71) #(0.807 1.0 0.87) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! openIcon ^ Icons at: #openIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 2661195422 2661195422 2052805237 2661195422 2661195422 2661195374 1670288984 2661195422 1045712204 947544694 2560334447 1772002974 864319859 1465093632 2627246230 1265475230 998997611 1889140892 2593691273 1548383348 998992519 0 2644333873 1143683360 982214222 1701076574 1564419650 892737814 848313671 2003986265 1346914600 521339703 847783826 2408807770 1110317582 84609950 979387799 2020102452 504301572 34280606 977367428 1632192052 436864774 67185054 490505098 2087477078 1076700193 454050718 490505098 2087477078 1076700193 454050718 223281152 10262933 2441971330 2150276766 159449088 40345 2492237183 2065014430 203763756 741090082 471340818 288333470) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.031 0.678) #(0.0 0.031 0.741) #(0.0 0.063 0.71) #(0.0 0.063 0.776) #(0.0 0.094 0.776) #(0.0 0.094 0.807) #(0.0 0.094 0.839) #(0.0 0.129 0.839) #(0.0 0.16 0.741) #(0.0 0.192 0.905) #(0.031 0.063 0.678) #(0.031 0.16 0.71) #(0.031 0.223 0.741) #(0.031 0.223 0.87) #(0.031 0.258 0.936) #(0.063 0.129 0.678) #(0.063 0.16 0.646) #(0.063 0.192 0.646) #(0.063 0.289 0.905) #(0.094 0.129 0.611) #(0.094 0.16 0.611) #(0.094 0.16 0.646) #(0.094 0.192 0.678) #(0.094 0.223 0.678) #(0.094 0.321 0.905) #(0.094 0.353 0.968) #(0.129 0.223 0.741) #(0.129 0.258 0.71) #(0.129 0.353 0.807) #(0.129 0.353 0.968) #(0.129 0.451 1.0) #(0.16 0.223 0.646) #(0.16 0.258 0.807) #(0.16 0.289 0.741) #(0.16 0.321 0.776) #(0.16 0.321 0.839) #(0.16 0.353 0.807) #(0.16 0.353 0.839) #(0.16 0.388 0.839) #(0.16 0.482 1.0) #(0.192 0.192 0.58) #(0.192 0.289 0.71) #(0.192 0.353 0.776) #(0.192 0.353 0.807) #(0.192 0.353 0.87) #(0.192 0.451 1.0) #(0.223 0.223 0.548) #(0.223 0.388 0.807) #(0.223 0.388 0.839) #(0.223 0.451 0.839) #(0.223 0.451 0.87) #(0.223 0.482 1.0) #(0.223 0.517 1.0) #(0.223 0.548 1.0) #(0.258 0.289 0.548) #(0.258 0.353 0.646) #(0.258 0.353 0.71) #(0.258 0.451 0.839) #(0.258 0.482 0.839) #(0.258 0.482 0.905) #(0.258 0.517 0.905) #(0.289 0.388 0.678) #(0.289 0.419 0.839) #(0.289 0.451 0.905) #(0.289 0.517 0.87) #(0.289 0.548 1.0) #(0.321 0.289 0.548) #(0.321 0.482 0.87) #(0.321 0.517 0.905) #(0.321 0.58 1.0) #(0.353 0.517 0.87) #(0.353 0.548 0.968) #(0.353 0.611 1.0) #(0.388 0.388 0.548) #(0.388 0.419 0.678) #(0.388 0.482 0.741) #(0.388 0.517 0.741) #(0.388 0.517 0.87) #(0.388 0.548 0.905) #(0.388 0.611 0.968) #(0.388 0.646 1.0) #(0.419 0.451 0.71) #(0.419 0.482 0.776) #(0.419 0.517 0.741) #(0.419 0.517 0.87) #(0.419 0.58 0.968) #(0.419 0.646 0.936) #(0.451 0.419 0.611) #(0.451 0.646 0.968) #(0.451 0.71 1.0) #(0.482 0.451 0.611) #(0.482 0.548 0.839) #(0.482 0.58 0.905) #(0.482 0.611 0.905) #(0.482 0.646 0.968) #(0.482 0.741 0.968) #(0.482 0.776 1.0) #(0.517 0.482 0.58) #(0.517 0.517 0.71) #(0.517 0.646 0.936) #(0.517 0.678 0.936) #(0.517 0.71 0.936) #(0.517 0.71 0.968) #(0.517 0.741 1.0) #(0.548 0.482 0.517) #(0.548 0.678 0.905) #(0.548 0.71 0.936) #(0.548 0.741 1.0) #(0.58 0.482 0.482) #(0.58 0.517 0.517) #(0.58 0.58 0.839) #(0.58 0.646 0.87) #(0.58 0.741 0.936) #(0.58 0.741 0.968) #(0.58 0.839 1.0) #(0.611 0.517 0.482) #(0.611 0.548 0.482) #(0.611 0.611 0.839) #(0.611 0.741 0.968) #(0.611 0.839 0.968) #(0.611 0.87 1.0) #(0.646 0.548 0.482) #(0.646 0.646 0.776) #(0.646 0.839 1.0) #(0.646 0.87 1.0) #(0.646 0.905 1.0) #(0.678 0.678 0.807) #(0.678 0.678 0.839) #(0.678 0.741 0.936) #(0.71 0.71 0.839) #(0.71 0.839 0.968) #(0.71 0.936 1.0) #(0.741 0.71 0.839) #(0.741 0.741 0.87) #(0.741 0.741 0.905) #(0.741 0.968 1.0) #(0.776 0.807 0.968) #(0.776 0.936 1.0) #(0.776 1.0 1.0) #(0.807 0.776 0.87) #(0.807 0.807 0.905) #(0.807 0.807 0.936) #(0.807 0.905 0.968) #(0.807 1.0 1.0) #(0.839 0.839 0.936) #(0.839 0.936 1.0) #(0.839 1.0 1.0) #(0.87 0.839 0.905) #(0.87 0.87 0.936) #(0.87 0.87 0.968) #(0.87 1.0 1.0) #(0.905 0.905 1.0) #(0.936 0.905 0.968) #(0.936 0.936 1.0) #(0.968 0.936 1.0) #(0.968 0.968 1.0) #(1.0 0.968 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! pasteIcon ^ Icons at: #pasteIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 2105376125 2097486601 2105376125 2105376125 708590651 572597788 506803247 142441853 1023433759 286788624 387269433 259882365 1046239827 1296845129 1212496435 259882365 1029396306 1313690393 336860180 336855933 1029264467 1330599187 0 4958 1012422229 1431392522 46 757795422 1012422229 1431392518 11821 724043358 1012422229 1431390982 11563 673646174 1012422229 1430997761 3024936 656802142 1012422229 1430994689 774645799 555745630 1012422229 1178550017 740828961 538771806 1012422218 1077886721 673653021 488243550 995051330 1077886721 235734790 67240286 691550263 909522485 1583242846 1583242877 2103402335 1600085855 1600085855 1602059645) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.58 0.741 0.905) #(0.58 0.741 0.936) #(0.611 0.646 0.646) #(0.611 0.776 0.936) #(0.646 0.58 0.517) #(0.646 0.776 0.936) #(0.646 0.807 0.936) #(0.678 0.548 0.451) #(0.678 0.611 0.58) #(0.678 0.807 0.936) #(0.71 0.776 0.741) #(0.71 0.776 0.839) #(0.71 0.839 0.936) #(0.71 0.839 0.968) #(0.741 0.517 0.321) #(0.741 0.776 0.807) #(0.741 0.807 0.839) #(0.741 0.839 0.905) #(0.741 0.87 0.968) #(0.741 0.87 1.0) #(0.776 0.741 0.646) #(0.776 0.807 0.741) #(0.776 0.807 0.807) #(0.776 0.839 0.839) #(0.776 0.839 0.87) #(0.776 0.839 0.905) #(0.807 0.807 0.807) #(0.807 0.87 0.87) #(0.807 0.87 0.936) #(0.839 0.646 0.451) #(0.839 0.839 0.776) #(0.839 0.87 0.936) #(0.839 0.905 0.936) #(0.87 0.58 0.353) #(0.87 0.839 0.776) #(0.87 0.905 0.87) #(0.87 0.905 0.905) #(0.87 0.905 0.936) #(0.87 0.905 0.968) #(0.905 0.936 0.968) #(0.936 0.451 0.129) #(0.936 0.482 0.129) #(0.936 0.936 0.968) #(0.936 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.419 0.0) #(1.0 0.419 0.094) #(1.0 0.451 0.063) #(1.0 0.482 0.063) #(1.0 0.517 0.0) #(1.0 0.517 0.031) #(1.0 0.517 0.063) #(1.0 0.517 0.094) #(1.0 0.548 0.094) #(1.0 0.548 0.129) #(1.0 0.58 0.063) #(1.0 0.611 0.063) #(1.0 0.611 0.258) #(1.0 0.611 0.289) #(1.0 0.646 0.321) #(1.0 0.646 0.353) #(1.0 0.71 0.192) #(1.0 0.71 0.223) #(1.0 0.71 0.258) #(1.0 0.741 0.258) #(1.0 0.776 0.223) #(1.0 0.776 0.258) #(1.0 0.776 0.321) #(1.0 0.776 0.353) #(1.0 0.776 0.388) #(1.0 0.807 0.353) #(1.0 0.807 0.388) #(1.0 0.807 0.419) #(1.0 0.807 0.517) #(1.0 0.839 0.419) #(1.0 0.839 0.451) #(1.0 0.839 0.482) #(1.0 0.839 0.517) #(1.0 0.839 0.548) #(1.0 0.839 0.58) #(1.0 0.87 0.517) #(1.0 0.87 0.548) #(1.0 0.87 0.58) #(1.0 0.87 0.611) #(1.0 0.87 0.646) #(1.0 0.905 0.611) #(1.0 0.905 0.646) #(1.0 0.905 0.71) #(1.0 0.968 0.839) #(1.0 0.968 0.87) #(1.0 1.0 0.936) #(0.0 0.0 0.0) #(0.258 0.396 0.451) #(0.772 0.369 0.109) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! printIcon ^ Icons at: #printIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 2122219071 757011070 2122219134 2122219134 2118073670 1702582553 2122219134 2122219134 1081344000 2087940896 1132363390 2122219134 1014562940 2020831822 427720318 2122219134 2118844416 2020830573 538122878 2122219134 2117499136 2054646354 570753284 192839294 2118406400 1901540108 117637641 1192132222 2117417836 1294141958 136929024 3615870 507668819 706224456 1979711612 1866468734 375152228 1281325312 2088067418 1326910846 375084647 2038199662 1632913713 338169214 359686741 1717984080 1161310784 1613893502 456814699 1481986117 1247639676 2004307729 2116429685 2036810083 32124 1832915749 2122199068 1514016815 1744859968 489389694 2122219060 237256574 892939828 2122219134) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.031 0.289 0.839) #(0.031 0.289 0.87) #(0.031 0.321 0.87) #(0.094 0.258 0.776) #(0.129 0.419 0.905) #(0.16 0.482 0.936) #(0.16 0.482 0.968) #(0.192 0.482 0.936) #(0.258 0.482 0.936) #(0.258 0.611 1.0) #(0.289 0.321 0.611) #(0.289 0.646 1.0) #(0.321 0.289 0.517) #(0.321 0.321 0.611) #(0.321 0.353 0.548) #(0.321 0.353 0.646) #(0.321 0.388 0.58) #(0.321 0.419 0.646) #(0.353 0.419 0.611) #(0.353 0.419 0.678) #(0.353 0.451 0.839) #(0.353 0.482 0.839) #(0.353 0.611 0.548) #(0.353 0.678 1.0) #(0.388 0.419 0.517) #(0.388 0.419 0.611) #(0.388 0.419 0.646) #(0.388 0.419 0.741) #(0.388 0.451 0.611) #(0.388 0.451 0.741) #(0.388 0.482 0.646) #(0.388 0.482 0.678) #(0.388 0.678 1.0) #(0.388 0.71 1.0) #(0.388 0.741 1.0) #(0.419 0.388 0.548) #(0.419 0.419 0.517) #(0.419 0.419 0.58) #(0.419 0.482 0.807) #(0.419 0.548 0.741) #(0.419 0.646 0.968) #(0.419 0.776 1.0) #(0.451 0.419 0.482) #(0.451 0.419 0.517) #(0.451 0.482 0.548) #(0.451 0.482 0.646) #(0.451 0.517 0.678) #(0.482 0.451 0.548) #(0.482 0.517 0.776) #(0.482 0.548 0.776) #(0.482 0.776 1.0) #(0.517 0.482 0.517) #(0.517 0.517 0.58) #(0.517 0.548 0.646) #(0.517 0.548 0.839) #(0.517 0.58 0.807) #(0.517 0.611 0.776) #(0.517 0.611 0.905) #(0.517 0.646 0.807) #(0.548 0.58 0.678) #(0.548 0.58 0.71) #(0.548 0.58 0.87) #(0.58 0.517 0.482) #(0.58 0.646 0.807) #(0.58 0.646 0.839) #(0.58 0.646 0.968) #(0.611 0.517 0.482) #(0.611 0.548 0.517) #(0.611 0.646 0.87) #(0.611 0.678 0.839) #(0.611 0.71 0.936) #(0.611 0.807 1.0) #(0.646 0.646 0.87) #(0.646 0.71 0.87) #(0.646 0.741 0.839) #(0.646 0.87 1.0) #(0.646 0.905 1.0) #(0.678 0.71 0.839) #(0.678 0.71 0.87) #(0.678 0.71 0.905) #(0.678 0.741 0.839) #(0.678 0.839 0.968) #(0.678 0.936 1.0) #(0.71 0.71 0.905) #(0.71 0.741 0.936) #(0.71 0.741 0.968) #(0.71 0.87 1.0) #(0.741 0.741 0.936) #(0.741 0.776 0.87) #(0.741 0.776 0.936) #(0.741 0.776 0.968) #(0.741 0.776 1.0) #(0.741 0.807 0.905) #(0.741 0.807 1.0) #(0.741 0.87 1.0) #(0.776 0.807 0.905) #(0.776 0.807 0.936) #(0.776 0.807 0.968) #(0.776 0.839 0.936) #(0.776 0.87 1.0) #(0.807 0.839 0.936) #(0.807 0.839 0.968) #(0.807 0.839 1.0) #(0.807 0.87 0.936) #(0.807 0.936 1.0) #(0.839 0.87 0.936) #(0.839 0.87 1.0) #(0.839 1.0 1.0) #(0.87 0.87 0.936) #(0.87 0.87 1.0) #(0.87 0.905 0.968) #(0.87 0.905 1.0) #(0.87 0.936 1.0) #(0.905 0.87 0.936) #(0.905 0.905 0.968) #(0.905 0.936 0.968) #(0.905 0.936 1.0) #(0.905 0.968 1.0) #(0.936 0.905 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.936 0.968) #(0.968 0.936 1.0) #(0.968 0.968 1.0) #(1.0 0.968 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! quitIcon ^ Icons at: #quitIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1583242846 1578177298 303042142 1583242846 1583242769 438447692 791551247 190733918 1583223839 976115543 1465331246 419978846 1578179663 1414987776 22351 773327198 1578448975 1459637304 944504919 1329138270 287324247 4995156 1412970496 1462638087 322459392 1429753600 5191736 5710085 305420032 943083264 5191224 5710852 255022848 943083264 5191224 5710852 271144704 1429753664 5191736 5710082 236858967 4995156 1396193280 1462637830 1578054446 1459637304 944504919 775095390 1577784644 777453568 22318 1141637982 1583220758 892229463 1462644277 218193502 1583242761 169552694 909514500 56516190 1583242846 1577518340 67241566 1583242846) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.451 0.129 0.094) #(0.482 0.031 0.031) #(0.482 0.16 0.129) #(0.517 0.0 0.0) #(0.517 0.031 0.031) #(0.517 0.16 0.129) #(0.548 0.16 0.129) #(0.58 0.129 0.094) #(0.58 0.16 0.129) #(0.611 0.0 0.0) #(0.611 0.16 0.129) #(0.646 0.0 0.0) #(0.646 0.031 0.031) #(0.646 0.16 0.129) #(0.678 0.0 0.0) #(0.678 0.031 0.031) #(0.678 0.16 0.129) #(0.71 0.0 0.0) #(0.71 0.031 0.031) #(0.71 0.129 0.094) #(0.741 0.0 0.0) #(0.741 0.031 0.031) #(0.741 0.063 0.063) #(0.741 0.094 0.094) #(0.741 0.129 0.129) #(0.776 0.0 0.0) #(0.776 0.063 0.063) #(0.807 0.031 0.031) #(0.807 0.223 0.223) #(0.839 0.0 0.0) #(0.839 0.031 0.031) #(0.839 0.063 0.063) #(0.87 0.0 0.0) #(0.87 0.192 0.192) #(0.87 0.289 0.289) #(0.905 0.0 0.0) #(0.905 0.031 0.031) #(0.905 0.094 0.094) #(0.905 0.16 0.16) #(0.905 0.192 0.192) #(0.936 0.0 0.0) #(0.936 0.063 0.063) #(0.936 0.129 0.129) #(0.936 0.16 0.16) #(0.936 0.353 0.353) #(0.936 0.388 0.388) #(0.936 0.451 0.451) #(0.936 0.548 0.548) #(0.936 0.646 0.646) #(0.936 0.741 0.741) #(0.968 0.0 0.0) #(0.968 0.063 0.063) #(0.968 0.094 0.094) #(0.968 0.129 0.129) #(0.968 0.192 0.192) #(0.968 0.321 0.321) #(0.968 0.388 0.388) #(0.968 0.517 0.517) #(0.968 0.548 0.548) #(0.968 0.646 0.646) #(0.968 0.71 0.71) #(0.968 0.776 0.776) #(0.968 0.87 0.87) #(0.968 0.936 0.936) #(0.968 0.968 0.968) #(1.0 0.0 0.0) #(1.0 0.031 0.031) #(1.0 0.063 0.063) #(1.0 0.094 0.094) #(1.0 0.129 0.129) #(1.0 0.16 0.16) #(1.0 0.192 0.192) #(1.0 0.192 0.223) #(1.0 0.223 0.223) #(1.0 0.258 0.258) #(1.0 0.289 0.289) #(1.0 0.321 0.321) #(1.0 0.353 0.353) #(1.0 0.482 0.482) #(1.0 0.517 0.517) #(1.0 0.548 0.548) #(1.0 0.58 0.58) #(1.0 0.611 0.611) #(1.0 0.646 0.646) #(1.0 0.678 0.678) #(1.0 0.71 0.71) #(1.0 0.741 0.741) #(1.0 0.807 0.807) #(1.0 0.839 0.839) #(1.0 0.87 0.87) #(1.0 0.905 0.905) #(1.0 0.936 0.936) #(1.0 0.968 0.968) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! redoIcon ^ Icons at: #redoIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 336860180 336860180 336860180 336860180 336860180 336860180 336855316 336860180 336860180 336860180 335614721 336860180 336860180 16843009 16844809 18093076 336860161 320017171 319296008 151065620 336855302 100861446 101060882 134807828 335610886 50594829 235868177 201397268 335610886 67371521 16844044 18093076 335611398 67240212 335612929 336860180 335611398 67179540 336855316 336860180 335610886 67179540 336860180 336860180 336855300 67179540 336860180 336860180 336860161 117571860 335610132 18093076 336860180 17236481 17236481 33625108 336860180 335610132 335610132 18093076 336860180 336860180 336860180 336860180) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.905 0.611 0.0) #(0.968 0.741 0.031) #(0.968 0.776 0.129) #(0.968 0.839 0.388) #(0.968 0.87 0.258) #(0.968 0.905 0.0) #(0.968 0.905 0.678) #(0.968 0.968 0.839) #(0.968 0.968 0.936) #(0.968 0.968 0.968) #(1.0 0.741 0.129) #(1.0 0.807 0.223) #(1.0 0.839 0.289) #(1.0 0.87 0.388) #(1.0 0.905 0.482) #(1.0 0.936 0.58) #(1.0 0.968 0.646) #(1.0 1.0 0.87) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! saveAsIcon ^ Icons at: #saveAsIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 2475922323 2475922323 2475922323 2357152915 2475922323 2475922323 2475922310 2356771219 2470594883 1027092007 538789766 2070891667 2471130880 974872320 9537151 2035061651 2470340984 504322816 9012861 1931907987 2469946993 1145008640 2458354812 1410831251 2469486691 1751672420 1821016186 621908883 2468895819 1094465075 1804304725 336499603 2468499787 1262762830 2374532651 302814099 2468365663 30325 2391108189 554210195 2468102234 1852268916 2407746878 419861395 2467837264 1835161456 2421567538 369398675 2467636287 1700352838 1378626093 335778707 2467503929 1582254135 757736232 268604307 2467109417 1481261885 875505704 218207123 2466907911 185140999 117901063 83989395) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.094) #(0.0 0.0 0.16) #(0.0 0.031 0.16) #(0.0 0.031 0.192) #(0.031 0.031 0.16) #(0.031 0.063 0.223) #(0.063 0.063 0.223) #(0.063 0.094 0.258) #(0.094 0.063 0.223) #(0.094 0.063 0.258) #(0.094 0.094 0.258) #(0.129 0.16 0.353) #(0.16 0.16 0.353) #(0.16 0.223 0.419) #(0.16 0.258 0.482) #(0.192 0.258 0.419) #(0.192 0.258 0.482) #(0.192 0.289 0.482) #(0.223 0.223 0.388) #(0.223 0.258 0.419) #(0.258 0.258 0.451) #(0.258 0.289 0.451) #(0.258 0.321 0.517) #(0.289 0.289 0.482) #(0.289 0.321 0.482) #(0.289 0.353 0.517) #(0.289 0.353 0.58) #(0.321 0.321 0.517) #(0.321 0.321 0.548) #(0.321 0.419 0.58) #(0.353 0.451 0.611) #(0.388 0.388 0.548) #(0.388 0.419 0.58) #(0.419 0.419 0.58) #(0.419 0.419 0.611) #(0.419 0.517 0.678) #(0.451 0.353 0.353) #(0.451 0.353 0.388) #(0.451 0.419 0.58) #(0.451 0.451 0.611) #(0.451 0.482 0.611) #(0.451 0.482 0.646) #(0.482 0.353 0.321) #(0.482 0.451 0.58) #(0.482 0.451 0.611) #(0.482 0.482 0.611) #(0.482 0.482 0.646) #(0.517 0.482 0.58) #(0.517 0.517 0.646) #(0.517 0.517 0.678) #(0.517 0.548 0.646) #(0.517 0.548 0.678) #(0.517 0.58 0.741) #(0.517 0.58 0.776) #(0.548 0.388 0.353) #(0.548 0.548 0.678) #(0.548 0.58 0.741) #(0.548 0.611 0.741) #(0.548 0.611 0.807) #(0.548 0.646 0.776) #(0.58 0.58 0.71) #(0.58 0.58 0.741) #(0.58 0.646 0.776) #(0.58 0.646 0.807) #(0.58 0.678 0.807) #(0.611 0.611 0.71) #(0.611 0.611 0.741) #(0.611 0.678 0.807) #(0.611 0.678 0.839) #(0.646 0.451 0.353) #(0.646 0.517 0.094) #(0.646 0.611 0.741) #(0.646 0.646 0.741) #(0.646 0.646 0.776) #(0.646 0.71 0.839) #(0.678 0.321 0.129) #(0.678 0.482 0.419) #(0.678 0.611 0.419) #(0.678 0.678 0.839) #(0.678 0.71 0.839) #(0.678 0.741 0.87) #(0.71 0.517 0.451) #(0.71 0.678 0.776) #(0.741 0.419 0.16) #(0.741 0.419 0.192) #(0.741 0.517 0.388) #(0.741 0.71 0.807) #(0.741 0.741 0.839) #(0.741 0.741 0.87) #(0.741 0.776 0.87) #(0.741 0.807 0.87) #(0.741 0.807 0.905) #(0.776 0.71 0.776) #(0.776 0.776 0.905) #(0.776 0.807 0.87) #(0.776 0.839 0.936) #(0.807 0.776 0.839) #(0.807 0.807 0.936) #(0.807 0.839 0.936) #(0.807 0.87 0.936) #(0.839 0.839 0.936) #(0.839 0.87 0.936) #(0.87 0.87 0.968) #(0.87 0.905 0.968) #(0.87 0.936 1.0) #(0.905 0.58 0.321) #(0.905 0.776 0.192) #(0.905 0.776 0.419) #(0.905 0.87 0.968) #(0.905 0.905 0.968) #(0.936 0.419 0.031) #(0.936 0.776 0.611) #(0.936 0.936 0.968) #(0.936 0.968 1.0) #(0.968 0.482 0.063) #(0.968 0.807 0.482) #(0.968 0.839 0.353) #(0.968 0.968 0.936) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.58 0.031) #(1.0 0.58 0.16) #(1.0 0.646 0.0) #(1.0 0.646 0.094) #(1.0 0.678 0.031) #(1.0 0.678 0.258) #(1.0 0.741 0.0) #(1.0 0.741 0.129) #(1.0 0.741 0.223) #(1.0 0.741 0.482) #(1.0 0.776 0.419) #(1.0 0.807 0.063) #(1.0 0.807 0.353) #(1.0 0.839 0.0) #(1.0 0.839 0.094) #(1.0 0.839 0.258) #(1.0 0.839 0.321) #(1.0 0.87 0.094) #(1.0 0.87 0.192) #(1.0 0.87 0.289) #(1.0 0.905 0.258) #(1.0 0.905 0.353) #(1.0 0.905 0.517) #(1.0 0.905 0.776) #(1.0 0.936 0.776) #(1.0 0.936 0.839) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! saveIcon ^ Icons at: #saveIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 1984713037 1195522356 757671199 420574838 1985115253 1159946869 1970632053 1798245238 1984458357 672489333 1970632053 1579879542 1984064369 1330213749 1970632053 1511786614 1983734889 1835887467 1751671645 924190838 1983209556 1262895420 842015772 387188598 1983209556 1262895420 842015772 387188598 1982945364 1414482240 942614306 454166390 1982945364 1414482240 942614306 454166390 1982681186 1970632050 1886020965 772671094 1982220894 1886152545 1549161299 705233782 1981825367 1868979289 1431193672 553976438 1981624905 1784437077 1313358659 503579254 1981295684 1633047374 1212103227 436339318 1980965430 1532120391 1044198709 318833014 1980697869 286264589 218959117 117508726) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.094) #(0.0 0.0 0.129) #(0.0 0.0 0.16) #(0.0 0.031 0.16) #(0.0 0.031 0.223) #(0.031 0.0 0.16) #(0.031 0.031 0.16) #(0.031 0.031 0.192) #(0.031 0.063 0.258) #(0.063 0.031 0.16) #(0.063 0.031 0.192) #(0.063 0.031 0.223) #(0.063 0.063 0.223) #(0.063 0.094 0.289) #(0.094 0.063 0.258) #(0.094 0.094 0.223) #(0.094 0.094 0.258) #(0.129 0.16 0.353) #(0.16 0.16 0.353) #(0.16 0.223 0.388) #(0.16 0.258 0.482) #(0.192 0.223 0.419) #(0.192 0.289 0.451) #(0.223 0.223 0.388) #(0.223 0.223 0.419) #(0.223 0.258 0.419) #(0.223 0.289 0.451) #(0.223 0.289 0.482) #(0.258 0.258 0.451) #(0.258 0.289 0.451) #(0.289 0.289 0.451) #(0.289 0.289 0.482) #(0.289 0.321 0.517) #(0.289 0.353 0.517) #(0.289 0.353 0.58) #(0.289 0.388 0.58) #(0.321 0.321 0.482) #(0.321 0.321 0.517) #(0.321 0.388 0.548) #(0.321 0.419 0.58) #(0.353 0.353 0.517) #(0.353 0.388 0.548) #(0.353 0.419 0.611) #(0.353 0.451 0.611) #(0.388 0.388 0.548) #(0.388 0.419 0.58) #(0.388 0.451 0.611) #(0.388 0.482 0.646) #(0.419 0.419 0.58) #(0.419 0.517 0.678) #(0.451 0.388 0.353) #(0.451 0.419 0.58) #(0.451 0.451 0.611) #(0.451 0.482 0.611) #(0.451 0.517 0.646) #(0.451 0.517 0.678) #(0.482 0.482 0.611) #(0.482 0.482 0.646) #(0.482 0.482 0.678) #(0.482 0.548 0.71) #(0.517 0.517 0.646) #(0.517 0.517 0.678) #(0.517 0.517 0.71) #(0.517 0.58 0.71) #(0.517 0.58 0.741) #(0.548 0.548 0.678) #(0.548 0.548 0.71) #(0.548 0.58 0.741) #(0.548 0.611 0.741) #(0.548 0.646 0.776) #(0.58 0.58 0.71) #(0.58 0.58 0.741) #(0.58 0.646 0.776) #(0.58 0.646 0.807) #(0.58 0.678 0.807) #(0.611 0.611 0.71) #(0.611 0.611 0.741) #(0.611 0.611 0.776) #(0.611 0.678 0.807) #(0.611 0.678 0.839) #(0.646 0.646 0.741) #(0.646 0.646 0.776) #(0.646 0.646 0.807) #(0.646 0.71 0.839) #(0.678 0.678 0.807) #(0.678 0.678 0.839) #(0.678 0.71 0.839) #(0.678 0.741 0.87) #(0.71 0.71 0.839) #(0.71 0.741 0.839) #(0.741 0.741 0.839) #(0.741 0.741 0.87) #(0.741 0.776 0.839) #(0.741 0.776 0.87) #(0.741 0.807 0.87) #(0.741 0.807 0.905) #(0.776 0.776 0.905) #(0.776 0.807 0.87) #(0.776 0.839 0.905) #(0.776 0.839 0.936) #(0.807 0.807 0.87) #(0.807 0.807 0.905) #(0.807 0.807 0.936) #(0.807 0.839 0.905) #(0.807 0.839 0.936) #(0.839 0.839 0.936) #(0.839 0.87 0.936) #(0.87 0.87 0.936) #(0.87 0.905 0.968) #(0.87 0.936 1.0) #(0.905 0.87 0.968) #(0.905 0.905 0.968) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! undoIcon ^ Icons at: #undoIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 370546198 370546198 370546198 370546198 370546198 369169942 370546198 370546198 370546198 18022678 370546198 370546198 370546177 151519489 16843009 370546198 370540809 135399443 320017171 18224662 369166600 303105542 101057286 100734486 370540812 286265102 218366979 100925718 370546177 201654529 16909316 100925718 370546198 17563926 369164804 101056790 370546198 369169942 370540804 101056790 370546198 370546198 370540804 100925718 370546198 370546198 370540804 67180054 370546177 369164566 369164807 18224662 370540802 16910081 16910081 370546198 370546177 369164566 369164566 370546198 370546198 370546198 370546198 370546198) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.0 0.004) #(0.905 0.611 0.0) #(0.968 0.741 0.031) #(0.968 0.776 0.129) #(0.968 0.839 0.388) #(0.968 0.87 0.258) #(0.968 0.905 0.0) #(0.968 0.905 0.678) #(0.968 0.968 0.839) #(0.968 0.968 0.936) #(0.968 0.968 0.968) #(1.0 0.741 0.129) #(1.0 0.807 0.223) #(1.0 0.839 0.289) #(1.0 0.87 0.388) #(1.0 0.905 0.482) #(1.0 0.936 0.58) #(1.0 0.968 0.646) #(1.0 1.0 0.87) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #( ) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'accessing - icons' stamp: 'sd 11/11/2003 11:31'! windowIcon ^ Icons at: #windowIcon ifAbsentPut: [((ColorForm extent: 16@16 depth: 8 fromArray: #( 354557466 403968528 252512520 100926209 592334387 857807123 286195711 100663042 793660989 1010251316 825098497 469827852 993869117 1010251316 825110062 471604267 989855744 0 0 1246317867 989855744 0 74 1229539626 989855744 0 0 42 989855744 0 19017 1229277482 989855744 0 4868425 1162168357 973078528 0 1246382405 1162167589 956301312 74 1246315845 1161905188 956301312 19018 1229276485 1094796068 956301312 19017 1229276482 1094795556 956301312 4868681 1162166849 1094730020 956301312 5065801 1229472835 1128350501 389165101 740763168 521870107 454761227) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.0 0.129 0.611) #(0.0 0.129 0.71) #(0.0 0.16 0.741) #(0.0 0.16 0.776) #(0.0 0.16 1.0) #(0.0 0.192 0.776) #(0.0 0.223 1.0) #(0.031 0.223 0.776) #(0.031 0.258 0.807) #(0.031 0.289 1.0) #(0.063 0.223 0.611) #(0.063 0.223 0.71) #(0.063 0.321 0.807) #(0.063 0.321 1.0) #(0.094 0.353 0.839) #(0.094 0.388 0.839) #(0.094 0.388 1.0) #(0.129 0.419 0.87) #(0.16 0.419 1.0) #(0.16 0.451 0.87) #(0.16 0.517 0.905) #(0.192 0.419 1.0) #(0.192 0.482 0.807) #(0.192 0.482 0.905) #(0.192 0.482 1.0) #(0.192 0.517 0.905) #(0.223 0.353 0.678) #(0.223 0.419 1.0) #(0.223 0.451 1.0) #(0.223 0.58 0.905) #(0.258 0.388 0.71) #(0.258 0.419 0.71) #(0.258 0.548 1.0) #(0.258 0.58 0.936) #(0.258 0.611 0.936) #(0.289 0.388 0.71) #(0.289 0.419 0.71) #(0.289 0.419 0.741) #(0.289 0.451 0.741) #(0.289 0.482 1.0) #(0.289 0.611 1.0) #(0.321 0.419 0.71) #(0.321 0.419 0.741) #(0.321 0.482 0.776) #(0.321 0.517 0.807) #(0.321 0.517 1.0) #(0.321 0.646 0.936) #(0.353 0.517 0.807) #(0.353 0.548 1.0) #(0.353 0.58 0.839) #(0.353 0.646 1.0) #(0.388 0.58 1.0) #(0.388 0.71 1.0) #(0.419 0.646 1.0) #(0.451 0.678 1.0) #(0.451 0.776 1.0) #(0.482 0.678 0.905) #(0.482 0.71 0.905) #(0.482 0.71 0.936) #(0.482 0.71 1.0) #(0.517 0.741 1.0) #(0.548 0.776 1.0) #(0.611 0.807 1.0) #(0.87 0.87 0.936) #(0.905 0.905 0.936) #(0.905 0.905 0.968) #(0.936 0.905 0.936) #(0.936 0.936 0.936) #(0.936 0.936 0.968) #(0.936 0.936 1.0) #(0.936 0.968 1.0) #(0.968 0.936 0.968) #(0.968 0.968 0.968) #(0.968 0.968 1.0) #(0.968 1.0 1.0) #(1.0 0.968 0.968) #(1.0 1.0 0.968) #(0.761 0.235 0.106) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) #(0.0 0.0 0.0) ))]! ! !MenuIcons class methodsFor: 'class initialization' stamp: 'nk 5/1/2004 16:41'! initialize "self initialize" | methods | Icons := IdentityDictionary new. methods := self class selectors select: [:each | '*Icon' match: each asString]. methods do: [:each | Icons at: each put: (MenuIcons perform: each)]. self initializeTranslations. Smalltalk addToStartUpList: self.! ! !MenuIcons class methodsFor: 'class initialization' stamp: 'nk 5/1/2004 16:49'! initializeTranslations "Initialize the dictionary of <translated menu string>-><icon>" TranslatedIcons := Dictionary new. self itemsIcons do: [ :assoc | assoc key do: [ :str | TranslatedIcons at: str translated asLowercase put: assoc value ] ]! ! !MenuIcons class methodsFor: 'class initialization' stamp: 'nk 5/1/2004 16:41'! startUp self initializeTranslations.! ! !MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 9/6/2004 23:53'! decorateMenu: aMenu "decorate aMenu with icons" | numberAdded | Preferences menuWithIcons ifFalse: [^ self]. numberAdded := 0. aMenu items do: [ :item | | icon | item icon isNil ifTrue:[ icon _ self iconForMenuItem: item. icon ifNotNil: [ item icon: icon. numberAdded := numberAdded + 1. ]]]. numberAdded isZero ifTrue: [^ self]. aMenu addBlankIconsIfNecessary: self blankIcon! ! !MenuIcons class methodsFor: 'menu decoration' stamp: 'nk 5/1/2004 16:48'! iconForMenuItem: anItem "Answer the icon (or nil) corresponding to the (translated) string." ^TranslatedIcons at: anItem contents asString asLowercase ifAbsent: [ ]! ! !MenuIcons class methodsFor: 'menu decoration' stamp: 'dgd 3/30/2003 19:17'! itemsIcons "answer a collection of associations wordings -> icon to decorate the menus all over the image" | icons | icons := OrderedCollection new. " world menu" icons add: #('previous project' ) -> self backIcon. icons add: #('jump to project...' ) -> self forwardIcon. icons add: #('open...' ) -> self openIcon. icons add: #('appearance...' ) -> self appearanceIcon. icons add: #('help...' ) -> self helpIcon. icons add: #('windows...' ) -> self windowIcon. icons add: #('print PS to file...' ) -> self printIcon. icons add: #('save' 'save project on file...' ) -> self saveIcon. icons add: #('save as...' 'save as new version' ) -> self saveAsIcon. icons add: #('quit' 'save and quit' ) -> self quitIcon. "" icons add: #('do it (d)' ) -> self doItIcon. icons add: #('inspect it (i)' 'explore it (I)' 'inspect world' 'explore world' 'inspect model' 'inspect morph' 'explore morph' 'inspect owner chain' 'explore' 'inspect' 'explore (I)' 'inspect (i)' 'basic inspect' ) -> self inspectIcon. icons add: #('print it (p)' ) -> self printIcon. "" icons add: #('copy (c)' ) -> self copyIcon. icons add: #('paste (v)' 'paste...' ) -> self pasteIcon. icons add: #('cut (x)' ) -> self cutIcon. "" icons add: #('accept (s)' ) -> self okIcon. icons add: #('cancel (l)' ) -> self cancelIcon. "" icons add: #('do again (j)' ) -> self redoIcon. icons add: #('undo (z)' ) -> self undoIcon. "" icons add: #('find...(f)' 'find again (g)' 'find class... (f)' 'find method...' ) -> self findIcon. "" icons add: #('remove' 'remove class (x)' 'delete method from changeset (d)' 'remove method from system (x)' 'delete class from change set (d)' 'remove class from system (x)' 'destroy change set (X)' ) -> self deleteIcon. icons add: #('add item...' 'new category...' ) -> self newIcon. "" icons add: #('new morph...' 'objects (o)' ) -> self morphsIcon. "" ^ icons! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 16:16'! exportAllIconsAsGif "self exportAllIconsAsGif" | sels | sels := self class selectors select: [:each | '*Icon' match: each asString]. sels do: [:each | self exportIcon: (MenuIcons perform: each) asGifNamed: each asString]. ! ! !MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'! exportAllIconsAsPNG "self exportAllIconsAsPNG" | sels | sels := self class selectors select: [:each | '*Icon' match: each asString]. sels do: [:each | self exportIcon: (MenuIcons perform: each) asPNGNamed: each asString]. ! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/11/2003 11:36'! exportIcon: image asGifNamed: aString "self exportIcon: self newIcon asGifNamed: 'newIcon'" | writer | writer := GIFReadWriter on: (FileStream newFileNamed: aString, '.gif'). [ writer nextPutImage: image] ensure: [writer close]! ! !MenuIcons class methodsFor: 'import/export' stamp: 'nk 2/16/2004 13:38'! exportIcon: image asPNGNamed: aString "self exportIcon: self newIcon asPNGNamed: 'newIcon'" | writer | writer := PNGReadWriter on: (FileStream newFileNamed: aString, '.png'). [ writer nextPutImage: image] ensure: [writer close]! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'! importAllIconNamed: aString "self importIconNamed: 'Icons16:appearanceIcon'" | writer image stream | writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif'). [ image := writer nextImage] ensure: [writer close]. stream := ReadWriteStream on: (String new). stream nextPutAll: aString ; cr. stream nextPutAll: (self methodStart: aString). image storeOn: stream. stream nextPutAll: self methodEnd. ^ stream contents! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 13:06'! importAllIcons "self importAllIcons; initialize" | icons | icons := FileDirectory default fileNames select: [:each | '*Icon.gif' match: each ]. icons do: [:icon | self importIconNamed: (icon upTo: $.)] ! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:05'! importIconNamed: aString "self importIconNamed: 'Icons16:appearanceIcon'" | writer image stream | writer := GIFReadWriter on: (FileStream fileNamed: aString, '.gif'). [ image := writer nextImage] ensure: [writer close]. stream := ReadWriteStream on: (String new). stream nextPutAll: aString ; cr. stream nextPutAll: (self methodStart: aString). image storeOn: stream. stream nextPutAll: self methodEnd. MenuIcons class compile: stream contents classified: 'accessing - icons' notifying: nil. ^ stream contents! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/9/2003 23:49'! methodEnd ^ ']'! ! !MenuIcons class methodsFor: 'import/export' stamp: 'sd 11/10/2003 00:04'! methodStart: aString ^'^ Icons at: #', aString, ' ifAbsentPut: ['! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 20:16'! adaptToWorld: aWorld super adaptToWorld: aWorld. target _ target adaptedToWorld: aWorld.! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:50'! allWordingsNotInSubMenus: verbotenSubmenuContentsList "Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContentsList" self isStayUpItem ifTrue:[^ #()]. subMenu ifNotNil: [^ (verbotenSubmenuContentsList includes: self contents asString) ifTrue: [#()] ifFalse: [subMenu allWordingsNotInSubMenus: verbotenSubmenuContentsList]]. ^ Array with: self contents asString! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:51'! contentString: aString aString isNil ifTrue: [self removeProperty: #contentString] ifFalse: [self setProperty: #contentString toValue: aString]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:55'! contents: aString withMarkers: aBool inverse: inverse "Set the menu item entry. If aBool is true, parse aString for embedded markers." | markerIndex marker | self contentString: nil. "get rid of old" aBool ifFalse: [^super contents: aString]. self removeAllMorphs. "get rid of old markers if updating" self hasIcon ifTrue: [ self icon: nil ]. (aString notEmpty and: [aString first = $<]) ifFalse: [^super contents: aString]. markerIndex := aString indexOf: $>. markerIndex = 0 ifTrue: [^super contents: aString]. marker := (aString copyFrom: 1 to: markerIndex) asLowercase. (#('<on>' '<off>' '<yes>' '<no>') includes: marker) ifFalse: [^super contents: aString]. self contentString: aString. "remember actual string" marker := (marker = '<on>' or: [marker = '<yes>']) ~= inverse ifTrue: [self onImage] ifFalse: [self offImage]. super contents: (aString copyFrom: markerIndex + 1 to: aString size). "And set the marker" marker := ImageMorph new image: marker. marker position: self left @ (self top + 2). self addMorphFront: marker! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! hasIcon "Answer whether the receiver has an icon." ^ icon notNil! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! hasIconOrMarker "Answer whether the receiver has an icon or a marker." ^ self hasIcon or: [ submorphs isEmpty not ]! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:25'! hasMarker "Answer whether the receiver has a marker morph." ^ submorphs isEmpty not! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'! icon "answer the receiver's icon" ^ icon! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'dgd 3/22/2003 14:45'! icon: aForm "change the the receiver's icon" icon := aForm! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'hg 12/8/2001 13:22'! isEnabled: aBoolean isEnabled = aBoolean ifTrue: [^ self]. isEnabled _ aBoolean. self color: (aBoolean ifTrue: [Color black] ifFalse: [Color lightGray]). ! ! !MenuItemMorph methodsFor: 'copying' stamp: 'sw 9/25/2002 03:24'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. target _ deepCopier references at: target ifAbsent: [target]. arguments notNil ifTrue: [arguments _ arguments collect: [:each | deepCopier references at: each ifAbsent: [each]]]! ! !MenuItemMorph methodsFor: 'copying' stamp: 'dgd 3/22/2003 14:56'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. isEnabled := isEnabled veryDeepCopyWith: deepCopier. subMenu := subMenu veryDeepCopyWith: deepCopier. isSelected := isSelected veryDeepCopyWith: deepCopier. icon := icon veryDeepCopyWith: deepCopier. "target := target. Weakly copied" "selector := selector. a Symbol" arguments := arguments! ! !MenuItemMorph methodsFor: 'drawing' stamp: 'nk 3/10/2004 15:46'! drawOn: aCanvas | stringColor stringBounds leftEdge | isSelected & isEnabled ifTrue: [ aCanvas fillRectangle: self bounds fillStyle: self selectionFillStyle. stringColor := color negated] ifFalse: [stringColor := color]. leftEdge := 0. self hasIcon ifTrue: [| iconForm | iconForm := isEnabled ifTrue:[self icon] ifFalse:[self icon asGrayScale]. aCanvas paintImage: iconForm at: self left @ (self top + (self height - iconForm height // 2)). leftEdge := iconForm width + 2]. self hasMarker ifTrue: [ leftEdge := leftEdge + self submorphBounds width + 8 ]. stringBounds := bounds left: bounds left + leftEdge. aCanvas drawString: contents in: stringBounds font: self fontToUse color: stringColor. subMenu ifNotNil: [aCanvas paintImage: SubMenuMarker at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! ! !MenuItemMorph methodsFor: 'drawing' stamp: 'dgd 8/30/2004 20:59'! selectionFillStyle "answer the fill style to use with the receiver is the selected element" | fill baseColor preferenced | Display depth <= 2 ifTrue: [^ Color gray]. preferenced := Preferences menuSelectionColor. preferenced notNil ifTrue:[^ preferenced]. baseColor := owner color negated. Preferences gradientMenu ifFalse: [^ baseColor]. fill := GradientFillStyle ramp: {0.0 -> baseColor twiceLighter . 1 -> baseColor twiceDarker}. fill origin: self topLeft. fill direction: self width @ 0. ^ fill! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 2/7/2001 00:03'! doButtonAction "Called programattically, this should trigger the action for which the receiver is programmed" self invokeWithEvent: nil! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 10/3/2002 02:16'! mouseEnter: evt "The mouse entered the receiver" owner ifNotNil: [owner stayUp ifFalse: [self mouseEnterDragging: evt]]! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 5/5/2001 00:25'! mouseLeave: evt "The mouse has left the interior of the receiver..." owner ifNotNil: [owner stayUp ifFalse: [self mouseLeaveDragging: evt]]! ! !MenuItemMorph methodsFor: 'events' stamp: 'dgd 2/22/2003 14:52'! mouseLeaveDragging: evt "The mouse left the receiver. Do nothing if we're not in a 'valid menu transition', meaning that the current hand focus must be aimed at the owning menu." owner ifNil: [^self]. evt hand mouseFocus == owner ifFalse: [^self]. "If we have a submenu, make sure we've got some time to enter it before actually leaving the menu item" subMenu isNil ifTrue: [owner selectItem: nil event: evt] ifFalse: [self addAlarm: #deselectTimeOut: with: evt after: 500]! ! !MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:34'! aboutToBeGrabbedBy: aHand "Don't allow the receiver to act outside a Menu" | menu box | (owner notNil and:[owner submorphs size = 1]) ifTrue:[ "I am a lonely menuitem already; just grab my owner" owner stayUp: true. ^owner aboutToBeGrabbedBy: aHand]. box _ self bounds. menu _ MenuMorph new defaultTarget: nil. menu addMorphFront: self. menu bounds: box. menu stayUp: true. self isSelected: false. ^menu! ! !MenuItemMorph methodsFor: 'grabbing' stamp: 'spfa 3/13/2004 18:32'! duplicateMorph: evt "Make and return a duplicate of the receiver's argument" | dup menu | dup _ self duplicate isSelected: false. menu _ MenuMorph new defaultTarget: nil. menu addMorphFront: dup. menu bounds: self bounds. menu stayUp: true. evt hand grabMorph: menu from: owner. "duplicate was ownerless so use #grabMorph:from: here" ^menu! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 extent: 10 @ 10! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:43'! initialize "initialize the state of the receiver" super initialize. "" contents _ ''. hasFocus _ false. isEnabled _ true. subMenu _ nil. isSelected _ false. target _ nil. selector _ nil. arguments _ nil. font _ Preferences standardMenuFont. self hResizing: #spaceFill; vResizing: #shrinkWrap! ! !MenuItemMorph methodsFor: 'layout' stamp: 'tlk 5/16/2004 19:47'! minHeight | iconHeight | iconHeight := self hasIcon ifTrue: [self icon height + 2] ifFalse: [0]. ^ self fontToUse height max: iconHeight! ! !MenuItemMorph methodsFor: 'layout' stamp: 'nk 4/14/2004 14:57'! minWidth | fontToUse iconWidth subMenuWidth markerWidth | fontToUse := self fontToUse. subMenuWidth := self hasSubMenu ifFalse: [0] ifTrue: [10]. iconWidth := self hasIcon ifTrue: [self icon width + 2] ifFalse: [0]. markerWidth := self hasMarker ifTrue: [ self submorphBounds width + 8 ] ifFalse: [ 0 ]. ^ (fontToUse widthOfString: contents) + subMenuWidth + iconWidth + markerWidth.! ! !MenuItemMorph methodsFor: 'private' stamp: 'hg 8/3/2000 15:21'! deselectItem | item | self isSelected: false. subMenu ifNotNil: [subMenu deleteIfPopUp]. (owner isKindOf: MenuMorph) ifTrue: [item _ owner popUpOwner. (item isKindOf: MenuItemMorph) ifTrue: [item deselectItem]]. ! ! !MenuItemMorph commentStamp: '<historical>' prior: 0! I represent an item in a menu. Instance variables: isEnabled <Boolean> True if the menu item can be executed. subMenu <MenuMorph | nil> The submenu to activate automatically when the user mouses over the item. isSelected <Boolean> True if the item is currently selected. target <Object> The target of the associated action. selector <Symbol> The associated action. arguments <Array> The arguments for the associated action. icon <Form | nil> An optional icon form to be displayed to my left. If I have a dynamic marker, created by strings like <yes> or <no> in my contents, it will be installed as a submorph.! !MenuItemMorph class methodsFor: 'scripting' stamp: 'sw 2/7/2001 00:04'! additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((button ( (command fire 'trigger any and all of this object''s button actions')))) ! ! !MenuLineMorph methodsFor: 'drawing' stamp: 'sd 11/8/2003 16:00'! drawOn: aCanvas | baseColor | baseColor := Preferences menuColorFromWorld ifTrue: [owner color twiceDarker] ifFalse: [Preferences menuAppearance3d ifTrue: [owner color] ifFalse: [Preferences menuLineColor]]. Preferences menuAppearance3d ifTrue: [ aCanvas fillRectangle: (bounds topLeft corner: bounds rightCenter) color: baseColor twiceDarker. aCanvas fillRectangle: (bounds leftCenter corner: bounds bottomRight) color: baseColor twiceLighter] ifFalse: [ aCanvas fillRectangle: (bounds topLeft corner: bounds bottomRight) color: baseColor]! ! !MenuLineMorph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:52'! minHeight "answer the receiver's minHeight" ^ 2! ! !MenuLineMorph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'! minWidth "answer the receiver's minWidth" ^ 10! ! !MenuMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:20'! addBlankIconsIfNecessary: anIcon "If any of my items have an icon, ensure that all do by using anIcon for those that don't" | withIcons withoutIcons | withIcons _ Set new. withoutIcons _ Set new. self items do: [ :item | item hasIconOrMarker ifTrue: [ withIcons add: item ] ifFalse: [ withoutIcons add: item ]. item hasSubMenu ifTrue: [ item subMenu addBlankIconsIfNecessary: anIcon ]]. (withIcons isEmpty or: [ withoutIcons isEmpty ]) ifTrue: [ ^self ]. withoutIcons do: [ :item | item icon: anIcon ].! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 8/30/2003 20:44'! allWordings "Answer a collection of the wordings of all items and subitems, omitting the window-list in the embed... branch and (unless a certain hard-coded preference is set) also omitting items from the debug menu" | verboten | verboten _ OrderedCollection with: 'embed into'. Preferences debugMenuItemsInvokableFromScripts ifFalse: [verboten add: 'debug...' translated]. ^ self allWordingsNotInSubMenus: verboten! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 10/3/2002 20:11'! allWordingsNotInSubMenus: verbotenSubmenuContentsList "Answer a collection of the wordings of all items and subitems, but omit the stay-up item, and also any items in any submenu whose tag is in verbotenSubmenuContents" | aList | aList _ OrderedCollection new. self items do: [:anItem | aList addAll: (anItem allWordingsNotInSubMenus: verbotenSubmenuContentsList)]. ^ aList! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:22'! commandKeyHandler "Answer the receiver's commandKeyHandler" ^ self valueOfProperty: #commandKeyHandler ifAbsent: [nil]! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 12/4/2001 21:23'! commandKeyHandler: anObject "Set the receiver's commandKeyHandler. Whatever you set here needs to be prepared to respond to the message #commandKeyTypedIntoMenu: " self setProperty: #commandKeyHandler toValue: anObject! ! !MenuMorph methodsFor: 'accessing' stamp: 'hg 8/3/2000 15:29'! items ^ submorphs select: [:m | m isKindOf: MenuItemMorph] ! ! !MenuMorph methodsFor: 'accessing' stamp: 'nk 6/8/2004 16:52'! lastItem ^ submorphs reverse detect: [ :m | m isKindOf: MenuItemMorph ] ifNone: [ submorphs last ]! ! !MenuMorph methodsFor: 'accessing' stamp: 'dgd 2/21/2003 23:18'! lastSelection "Return the label of the last selected item or nil." selectedItem isNil ifTrue: [^selectedItem selector] ifFalse: [^nil]! ! !MenuMorph methodsFor: 'accessing' stamp: 'di 12/10/2001 22:11'! rootMenu popUpOwner ifNil: [^ self]. popUpOwner owner ifNil: [^ self]. ^ popUpOwner owner rootMenu! ! !MenuMorph methodsFor: 'accessing' stamp: 'nk 3/31/2002 15:13'! stayUp: aBoolean stayUp _ aBoolean. aBoolean ifTrue: [ self removeStayUpBox ].! ! !MenuMorph methodsFor: 'construction' stamp: 'hg 8/3/2000 15:22'! add: aString subMenu: aMenuMorph "Append the given submenu with the given label." | item | item _ MenuItemMorph new. item contents: aString; subMenu: aMenuMorph. self addMorphBack: item. ! ! !MenuMorph methodsFor: 'construction' stamp: 'ar 12/16/2001 16:53'! add: aString subMenu: aMenuMorph target: target selector: aSymbol argumentList: argList "Append the given submenu with the given label." | item | item _ MenuItemMorph new. item contents: aString; target: target; selector: aSymbol; arguments: argList asArray; subMenu: aMenuMorph. self addMorphBack: item. ^item! ! !MenuMorph methodsFor: 'construction' stamp: 'hg 8/3/2000 15:22'! add: aString target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument." | item | item _ MenuItemMorph new contents: aString; target: target; selector: aSymbol; arguments: argList asArray. self addMorphBack: item. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 2/27/2001 07:50'! addList: aList "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help." aList do: [:tuple | (tuple == #-) ifTrue: [self addLine] ifFalse: [self add: tuple first action: tuple second. tuple size > 2 ifTrue: [self balloonTextForLastItem: tuple third]]]! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:19'! addService: aService for: serviceUser "Append a menu item with the given service. If the item is selected, it will perform the given service." aService addServiceFor: serviceUser toMenu: self.! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 2/15/2004 16:11'! addServices2: services for: served extraLines: linesArray services withIndexDo: [:service :i | service addServiceFor: served toMenu: self. self lastItem setBalloonText: service description. (linesArray includes: i) ifTrue: [self addLine] ] ! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 11/26/2002 13:53'! addServices: services for: served extraLines: linesArray services withIndexDo: [:service :i | self addService: service for: served. submorphs last setBalloonText: service description. (linesArray includes: i) | service useLineAfter ifTrue: [self addLine]]. ! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 3/22/2003 19:27'! addStayUpIcons | title closeBox pinBox | title := submorphs detect: [:ea | ea hasProperty: #titleString] ifNone: [self setProperty: #needsTitlebarWidgets toValue: true. ^ self]. closeBox := IconicButton new target: self; actionSelector: #delete; labelGraphic: self class closeBoxImage; color: Color transparent; extent: 14 @ 16; borderWidth: 0. pinBox := IconicButton new target: self; actionSelector: #stayUp:; arguments: {true}; labelGraphic: self class pushPinImage; color: Color transparent; extent: 14 @ 15; borderWidth: 0. Preferences noviceMode ifTrue: [closeBox setBalloonText: 'close this menu'. pinBox setBalloonText: 'keep this menu up']. self addMorphFront: (AlignmentMorph newRow vResizing: #shrinkWrap; layoutInset: 0; color: Color transparent"Preferences menuTitleColor"; addMorphBack: closeBox; addMorphBack: title; addMorphBack: pinBox). self setProperty: #hasTitlebarWidgets toValue: true. self removeProperty: #needsTitlebarWidgets. self removeStayUpItems! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! addStayUpItem "Append a menu item that can be used to toggle this menu's persistence." (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) ifTrue: [ ^self ]. self addStayUpIcons.! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 4/6/2002 22:41'! addStayUpItemSpecial "Append a menu item that can be used to toggle this menu's persistent." "This variant is resistant to the MVC compatibility in #setInvokingView:" (self valueOfProperty: #hasTitlebarWidgets ifAbsent: [ false ]) ifTrue: [ ^self ]. self addStayUpIcons.! ! !MenuMorph methodsFor: 'construction' stamp: 'dgd 3/22/2003 19:25'! addTitle: aString updatingSelector: aSelector updateTarget: aTarget "Add a title line at the top of this menu Make aString its initial contents. If aSelector is not nil, then periodically obtain fresh values for its contents by sending aSelector to aTarget.." | title | title := AlignmentMorph new. self setTitleParametersFor: title. title vResizing: #shrinkWrap. title listDirection: #topToBottom. title wrapCentering: #center; cellPositioning: #topCenter; layoutInset: 0. aSelector ifNil: [(aString asString findTokens: String cr) do: [:line | title addMorphBack: (StringMorph new contents: line; font: Preferences standardMenuFont)]] ifNotNil: [title addMorphBack: (UpdatingStringMorph new lock; font: Preferences standardMenuFont; useStringFormat; target: aTarget; getSelector: aSelector)]. title setProperty: #titleString toValue: aString. self addMorphFront: title. (self hasProperty: #needsTitlebarWidgets) ifTrue: [self addStayUpIcons]! ! !MenuMorph methodsFor: 'construction' stamp: 'nk 11/25/2003 09:59'! addTranslatedList: aList "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. If an element of the list is simply the symobl $-, add a line to the receiver. The optional third element of each entry, if present, provides balloon help. The first and third items will be translated." aList do: [:tuple | (tuple == #-) ifTrue: [self addLine] ifFalse: [self add: tuple first translated action: tuple second. tuple size > 2 ifTrue: [self balloonTextForLastItem: tuple third translated ]]]! ! !MenuMorph methodsFor: 'construction' stamp: 'yo 7/16/2003 15:15'! labels: labelList lines: linesArray selections: selectionsArray "This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | labelArray := (labelList isString) ifTrue: [labelList findTokens: String cr] ifFalse: [labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]! ! !MenuMorph methodsFor: 'control' stamp: 'hg 8/3/2000 15:28'! deleteIfPopUp "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." stayUp ifFalse: [self topRendererOrSelf delete]. (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [ popUpOwner isSelected: false. (popUpOwner owner isKindOf: MenuMorph) ifTrue: [popUpOwner owner deleteIfPopUp]]. ! ! !MenuMorph methodsFor: 'control' stamp: 'dgd 3/21/2003 22:36'! popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | delta tryToPlace selectedOffset | hand world startSteppingSubmorphsOf: self. popUpOwner := sourceItem. self fullBounds. self updateColor. "ensure layout is current" selectedOffset := (selectedItem ifNil: [self items first]) position - self position. tryToPlace := [:where :mustFit | self position: where - selectedOffset. delta := self fullBoundsInWorld amountToTranslateWithin: sourceItem worldBounds. (delta x = 0 or: [mustFit]) ifTrue: [delta = (0 @ 0) ifFalse: [self position: self position + delta]. sourceItem owner owner addMorphFront: self. ^ self]]. tryToPlace value: rightOrLeftPoint first value: false; value: rightOrLeftPoint last - (self width @ 0) value: false; value: rightOrLeftPoint first value: true! ! !MenuMorph methodsFor: 'control' stamp: 'ar 12/27/2001 22:46'! popUpAt: aPoint forHand: hand in: aWorld "Present this menu at the given point under control of the given hand. Allow keyboard input into the menu." ^ self popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: Preferences menuKeyboardControl! ! !MenuMorph methodsFor: 'control' stamp: 'tak 1/6/2005 13:28'! popUpAt: aPoint forHand: hand in: aWorld allowKeyboard: aBoolean "Present this menu at the given point under control of the given hand." | evt | aWorld submorphs select: [ :each | (each isKindOf: MenuMorph) and: [each stayUp not]] thenCollect: [ :menu | menu delete]. self items isEmpty ifTrue: [^ self]. MenuIcons decorateMenu: self. (self submorphs select: [:m | m isKindOf: UpdatingMenuItemMorph]) do: [:m | m updateContents]. "precompute width" self positionAt: aPoint relativeTo: (selectedItem ifNil: [self items first]) inWorld: aWorld. aWorld addMorphFront: self. "Acquire focus for valid pop up behavior" hand newMouseFocus: self. aBoolean ifTrue: [hand newKeyboardFocus: self]. evt := hand lastEvent. (evt isKeyboard or: [evt isMouse and: [evt anyButtonPressed not]]) ifTrue: ["Select first item if button not down" self moveSelectionDown: 1 event: evt]. self updateColor. self changed! ! !MenuMorph methodsFor: 'control' stamp: 'sw 4/24/2001 11:11'! popUpEvent: evt in: aWorld "Present this menu in response to the given event." | aHand aPosition | aHand _ evt ifNotNil: [evt hand] ifNil: [ActiveHand]. aPosition _ aHand position truncated. ^ self popUpAt: aPosition forHand: aHand in: aWorld ! ! !MenuMorph methodsFor: 'control' stamp: 'ar 3/18/2001 00:33'! popUpForHand: hand in: aWorld | p | "Present this menu under control of the given hand." p _ hand position truncated. ^self popUpAt: p forHand: hand in: aWorld ! ! !MenuMorph methodsFor: 'control' stamp: 'sw 2/18/2001 00:52'! popUpInWorld "Present this menu in the current World" ^ self popUpInWorld: self currentWorld! ! !MenuMorph methodsFor: 'control' stamp: 'sw 12/17/2001 16:43'! popUpNoKeyboard "Present this menu in the current World, *not* allowing keyboard input into the menu" ^ self popUpAt: ActiveHand position forHand: ActiveHand in: ActiveWorld allowKeyboard: false! ! !MenuMorph methodsFor: 'control' stamp: 'dgd 3/22/2003 19:56'! updateColor | fill title | Preferences gradientMenu ifFalse: [^ self]. "" fill := GradientFillStyle ramp: {0.0 -> self color lighter. 1 -> self color darker}. "" fill origin: self topLeft. fill direction: self width @ 0. "" self fillStyle: fill. " update the title color" title := self allMorphs detect: [:each | each hasProperty: #titleString] ifNone: [^ self]. "" fill := GradientFillStyle ramp: {0.0 -> title color twiceLighter. 1 -> title color twiceDarker}. "" fill origin: title topLeft. fill direction: title width @ 0. "" title fillStyle: fill! ! !MenuMorph methodsFor: 'control' stamp: 'sw 2/7/2002 12:06'! wantsToBeDroppedInto: aMorph "Return true if it's okay to drop the receiver into aMorph. A single-item MenuMorph is in effect a button rather than a menu, and as such should not be reluctant to be dropped into another object." ^ (aMorph isWorldMorph or: [submorphs size == 1]) or: [Preferences systemWindowEmbedOK]! ! !MenuMorph methodsFor: 'drawing' stamp: 'sw 12/18/2001 23:45'! drawOn: aCanvas "Draw the menu. Add keyboard-focus feedback if appropriate" super drawOn: aCanvas. (ActiveHand notNil and: [ActiveHand keyboardFocus == self] and: [self rootMenu hasProperty: #hasUsedKeyboard]) ifTrue: [aCanvas frameAndFillRectangle: self innerBounds fillColor: Color transparent borderWidth: 1 borderColor: Preferences keyboardFocusColor]! ! !MenuMorph methodsFor: 'events' stamp: 'di 12/5/2001 10:26'! handleFocusEvent: evt "Handle focus events. Valid menu transitions are determined based on the menu currently holding the focus after the mouse went down on one of its children." self processEvent: evt. "Need to handle keyboard input if we have the focus." evt isKeyboard ifTrue: [^ self handleEvent: evt]. "We need to handle button clicks outside and transitions to local popUps so throw away everything else" (evt isMouseOver or:[evt isMouse not]) ifTrue:[^self]. "What remains are mouse buttons and moves" evt isMove ifFalse:[^self handleEvent: evt]. "handle clicks outside by regular means" "Now it's getting tricky. On #mouseMove we might transfer control to *either* the currently active submenu or the pop up owner, if any. Since the active sub menu is always displayed upfront check it first." selectedItem ifNotNil:[(selectedItem activateSubmenu: evt) ifTrue:[^self]]. "Note: The following does not traverse upwards but it's the best I can do for now" popUpOwner ifNotNil:[(popUpOwner activateOwnerMenu: evt) ifTrue:[^self]].! ! !MenuMorph methodsFor: 'initialization' stamp: 'dgd 3/22/2003 18:46'! setDefaultParameters | colorFromMenu worldColor menuColor menuBorderColor | colorFromMenu := Preferences menuColorFromWorld and: [Display depth > 4] and: [(worldColor := self currentWorld color) isColor]. "" menuColor := colorFromMenu ifTrue: [worldColor luminance > 0.7 ifTrue: [worldColor mixed: 0.85 with: Color black] ifFalse: [worldColor mixed: 0.4 with: Color white]] ifFalse: [Preferences menuColor]. "" menuBorderColor := Preferences menuAppearance3d ifTrue: [#raised] ifFalse: [colorFromMenu ifTrue: [worldColor muchDarker] ifFalse: [Preferences menuBorderColor]]. "" self setColor: menuColor borderWidth: Preferences menuBorderWidth borderColor: menuBorderColor. "" self layoutInset: 3! ! !MenuMorph methodsFor: 'initialization' stamp: 'dgd 3/22/2003 19:58'! setTitleParametersFor: aMenuTitle | menuTitleColor menuTitleBorderColor | Preferences roundedMenuCorners ifTrue: [aMenuTitle useRoundedCorners]. "" menuTitleColor := Preferences menuColorFromWorld ifTrue: [self color darker] ifFalse: [Preferences menuTitleColor]. "" menuTitleBorderColor := Preferences menuAppearance3d ifTrue: [#inset] ifFalse: [Preferences menuColorFromWorld ifTrue: [self color darker muchDarker] ifFalse: [Preferences menuTitleBorderColor]]. "" aMenuTitle setColor: menuTitleColor borderWidth: Preferences menuTitleBorderWidth borderColor: menuTitleBorderColor! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'cmm 3/26/2003 22:52'! displayFiltered: evt | matchStr allItems isMatch matches feedbackMorph | matchStr _ self valueOfProperty: #matchString. allItems _ self submorphs select: [:m | m isKindOf: MenuItemMorph]. matches _ allItems select: [:m | isMatch _ matchStr isEmpty or: [ m contents includesSubstring: matchStr caseSensitive: false]. m isEnabled: isMatch. isMatch]. feedbackMorph _ self valueOfProperty: #feedbackMorph. feedbackMorph ifNil: [ feedbackMorph _ TextMorph new autoFit: true; color: Color darkGray. self addLine; addMorphBack: feedbackMorph lock. self setProperty: #feedbackMorph toValue: feedbackMorph. self fullBounds. "Lay out for submorph adjacency"]. feedbackMorph contents: '<', matchStr, '>'. matchStr isEmpty ifTrue: [ feedbackMorph delete. self submorphs last delete. self removeProperty: #feedbackMorph]. matches size >= 1 ifTrue: [ self selectItem: matches first event: evt] ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'sw 12/4/2001 20:13'! handlesKeyboard: evt "Answer whether the receiver handles the keystroke represented by the event" ^ evt anyModifierKeyPressed not or: [evt commandKeyPressed and: [self commandKeyHandler notNil]]! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'laza 5/6/2004 13:59'! keyStroke: evt | matchString char asc selectable help | help _ BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. help popUpForHand: self activeHand. (self rootMenu hasProperty: #hasUsedKeyboard) ifFalse: [self rootMenu setProperty: #hasUsedKeyboard toValue: true. self changed]. (evt commandKeyPressed and: [self commandKeyHandler notNil]) ifTrue: [self commandKeyHandler commandKeyTypedIntoMenu: evt. ^self deleteIfPopUp: evt]. char := evt keyCharacter. asc := char asciiValue. char = Character cr ifTrue: [selectedItem ifNotNil: [selectedItem hasSubMenu ifTrue: [evt hand newMouseFocus: selectedItem subMenu. ^evt hand newKeyboardFocus: selectedItem subMenu] ifFalse: ["self delete." ^selectedItem invokeWithEvent: evt]]. (selectable := self items) size = 1 ifTrue: [^selectable first invokeWithEvent: evt]. ^self]. asc = 27 ifTrue: ["escape key" self valueOfProperty: #matchString ifPresentDo: [:str | str isEmpty ifFalse: ["If filtered, first ESC removes filter" self setProperty: #matchString toValue: String new. self selectItem: nil event: evt. ^self displayFiltered: evt]]. "If a stand-alone menu, just delete it" popUpOwner ifNil: [^self delete]. "If a sub-menu, then deselect, and return focus to outer menu" self selectItem: nil event: evt. evt hand newMouseFocus: popUpOwner owner. ^evt hand newKeyboardFocus: popUpOwner owner]. (asc = 28 or: [asc = 29]) ifTrue: ["left or right arrow key" (selectedItem notNil and: [selectedItem hasSubMenu]) ifTrue: [evt hand newMouseFocus: selectedItem subMenu. selectedItem subMenu moveSelectionDown: 1 event: evt. ^evt hand newKeyboardFocus: selectedItem subMenu]]. asc = 30 ifTrue: [^self moveSelectionDown: -1 event: evt]. "up arrow key" asc = 31 ifTrue: [^self moveSelectionDown: 1 event: evt]. "down arrow key" asc = 11 ifTrue: [^self moveSelectionDown: -5 event: evt]. "page up key" asc = 12 ifTrue: [^self moveSelectionDown: 5 event: evt]. "page down key" matchString := self valueOfProperty: #matchString ifAbsentPut: [String new]. matchString := char = Character backspace ifTrue: [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] ifFalse: [matchString copyWith: evt keyCharacter]. self setProperty: #matchString toValue: matchString. self displayFiltered: evt. help _ BalloonMorph string: 'Enter text to\narrow selection down\to matching items ' withCRs for: self corner: #topLeft. help popUpForHand: self activeHand. ! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/5/2001 11:41'! keyboardFocusChange: aBoolean "Notify change due to green border for keyboard focus" self changed! ! !MenuMorph methodsFor: 'keyboard control' stamp: 'di 12/10/2001 22:52'! moveSelectionDown: direction event: evt "Move the current selection up or down by one, presumably under keyboard control. direction = +/-1" | index m | index _ (submorphs indexOf: selectedItem ifAbsent: [1-direction]) + direction. submorphs do: "Ensure finite" [:unused | m _ submorphs atWrap: index. ((m isKindOf: MenuItemMorph) and: [m isEnabled]) ifTrue: [^ self selectItem: m event: evt]. "Keep looking for an enabled item" index _ index + direction sign]. ^ self selectItem: nil event: evt! ! !MenuMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:52'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'add title...' translated action: #addTitle. aCustomMenu add: 'set target...' translated action: #setTarget:. defaultTarget ifNotNil: [ aCustomMenu add: 'add item...' translated action: #addItem]. aCustomMenu add: 'add line' translated action: #addLine. (self items count:[:any| any hasSubMenu]) > 0 ifTrue:[aCustomMenu add: 'detach submenu' translated action: #detachSubMenu:].! ! !MenuMorph methodsFor: 'menu' stamp: 'hg 8/3/2000 15:29'! detachSubMenu: evt | possibleTargets item subMenu | possibleTargets _ evt hand argumentOrNil morphsAt: evt hand targetOffset. item _ possibleTargets detect: [:each | each isKindOf: MenuItemMorph] ifNone: [^ self]. subMenu _ item subMenu. subMenu ifNotNil: [ item subMenu: nil. item delete. subMenu stayUp: true. subMenu popUpOwner: nil. subMenu addTitle: item contents. evt hand attachMorph: subMenu]. ! ! !MenuMorph methodsFor: 'menu' stamp: 'sw 3/17/2005 23:59'! doButtonAction "Do the receiver's inherent button action. Makes sense for the kind of MenuMorph that is a wrapper for a single menu-item -- pass it on the the item" (self findA: MenuItemMorph) ifNotNilDo: [:aMenuItem | aMenuItem doButtonAction]! ! !MenuMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 13:10'! removeStayUpBox | box | submorphs isEmpty ifTrue: [^self]. (submorphs first isAlignmentMorph) ifFalse: [^self]. box := submorphs first submorphs last. (box isKindOf: IconicButton) ifTrue: [box labelGraphic: (Form extent: box extent depth: 8); shedSelvedge; borderWidth: 0; lock]! ! !MenuMorph methodsFor: 'menu' stamp: 'nk 3/31/2002 18:36'! removeStayUpItems | stayUpItems | stayUpItems _ self items select: [ :item | item isStayUpItem ]. stayUpItems do: [ :ea | ea delete ]. ! ! !MenuMorph methodsFor: 'menu' stamp: 'efo 3/27/2003 23:32'! setInvokingView: invokingView "Re-work every menu item of the form <target> perform: <selector> to the form <target> perform: <selector> orSendTo: <invokingView>. This supports MVC's vectoring of non-model messages to the editPane." self items do: [:item | item hasSubMenu ifTrue: [ item subMenu setInvokingView: invokingView] ifFalse: [ item arguments isEmpty ifTrue: "only the simple messages" [item arguments: (Array with: item selector with: invokingView). item selector: #perform:orSendTo:]]]! ! !MenuMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:55'! setTarget: evt "Set the default target object to be used for add item commands, and re-target all existing items to the new target or the the invoking hand." | rootMorphs old | rootMorphs := self world rootMorphsAt: evt hand targetOffset. rootMorphs size > 1 ifTrue: [defaultTarget := rootMorphs second] ifFalse: [^self]. "re-target all existing items" self items do: [:item | old := item target. old isHandMorph ifTrue: [item target: evt hand] ifFalse: [item target: defaultTarget]]! ! !MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'! invokeModal "Invoke this menu and don't return until the user has chosen a value. See example below on how to use modal menu morphs." ^ self invokeModal: Preferences menuKeyboardControl "Example: | menu sub entry | menu _ MenuMorph new. 1 to: 3 do: [:i | entry _ 'Line', i printString. sub _ MenuMorph new. menu add: entry subMenu: sub. #('Item A' 'Item B' 'Item C') do:[:subEntry| sub add: subEntry target: menu selector: #modalSelection: argument: {entry. subEntry}]]. menu invokeModal. " ! ! !MenuMorph methodsFor: 'modal control' stamp: 'sw 2/3/2002 14:26'! invokeModal: allowKeyboardControl "Invoke this menu and don't return until the user has chosen a value. If the allowKeyboarControl boolean is true, permit keyboard control of the menu" ^ self invokeModalAt: ActiveHand position in: ActiveWorld allowKeyboard: allowKeyboardControl! ! !MenuMorph methodsFor: 'modal control' stamp: 'KLC 4/11/2004 09:06'! invokeModalAt: aPoint in: aWorld allowKeyboard: aBoolean "Invoke this menu and don't return until the user has chosen a value. See senders of this method for finding out how to use modal menu morphs." | w originalFocusHolder | originalFocusHolder _ aWorld primaryHand keyboardFocus. self popUpAt: aPoint forHand: aWorld primaryHand in: aWorld allowKeyboard: aBoolean. self isModalInvokationDone: false. w _ aWorld outermostWorldMorph. "containing hand" [self isInWorld & self isModalInvokationDone not] whileTrue: [w doOneSubCycle]. self delete. originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. ^ self modalSelection! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:33'! isModalInvokationDone ^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! isModalInvokationDone: aBool self setProperty: #isModalInvokationDone toValue: aBool ! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection ^self valueOfProperty: #modalSelection ifAbsent:[nil]! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection: anObject self setProperty: #modalSelection toValue: anObject. self isModalInvokationDone: true! ! !MenuMorph methodsFor: 'private' stamp: 'ar 2/10/2001 00:37'! morphicLayerNumber "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^self valueOfProperty: #morphicLayerNumber ifAbsent: [ stayUp ifTrue:[100] ifFalse:[10] ]! ! !MenuMorph methodsFor: 'private' stamp: 'sw 5/1/2002 01:39'! positionAt: aPoint relativeTo: aMenuItem inWorld: aWorld "Note: items may not be laid out yet (I found them all to be at 0@0), so we have to add up heights of items above the selected item." | i yOffset sub delta | self fullBounds. "force layout" i _ 0. yOffset _ 0. [(sub _ self submorphs at: (i _ i + 1)) == aMenuItem] whileFalse: [yOffset _ yOffset + sub height]. self position: aPoint - (2 @ (yOffset + 8)). "If it doesn't fit, show it to the left, not to the right of the hand." self right > aWorld worldBounds right ifTrue: [self right: aPoint x + 1]. "Make sure that the menu fits in the world." delta _ self bounds amountToTranslateWithin: (aWorld worldBounds withHeight: ((aWorld worldBounds height - 18) max: (ActiveHand position y) + 1)). delta = (0 @ 0) ifFalse: [self position: self position + delta]! ! !MenuMorph class methodsFor: 'images' stamp: 'nk 8/1/2002 17:06'! closeBoxImage "Supplied here because we don't necessarily have ComicBold" ^ CloseBoxImage ifNil: [CloseBoxImage _ (Form extent: 10@16 depth: 2 fromArray: #( 0 0 0 0 1342259200 1409630208 353697792 89391104 22020096 89391104 353697792 1409630208 1342259200 0 0 0) offset: 0@0)]! ! !MenuMorph class methodsFor: 'images' stamp: 'nk 8/1/2002 17:03'! pushPinImage "Answer the push-pin image, creating and caching it at this time if it is absent" ^ PushPinImage ifNil: [PushPinImage _ ((ColorForm extent: 13@14 depth: 8 fromArray: #( 4294967295 4278387717 101187583 4278190080 4294967295 4278914061 235868177 4278190080 4294967295 303240213 370612249 4278190080 4294967295 454827294 522199330 587202560 4280624679 673786411 741158447 805306368 825373492 892745528 960117564 1023410176 1044332609 1111704645 1179076681 1241513984 1263291726 1330663762 1398035764 1442840576 1465407834 1532779870 1600151906 1660944384 1684366951 1751738987 1819148287 4278190080 4285559154 1937012086 2004418559 4278190080 2038070140 2101902975 2150891519 4278190080 2172814212 2240186248 327811071 4278190080 2324430732 2374930320 2449473535 4278190080) offset: 0@0) colorsFromArray: #(#(1.0 1.0 1.0) #(0.995 0.995 0.995) #(0.987 0.987 0.987) #(0.667 0.662 0.667) #(0.149 0.149 0.145) #(0.254 0.262 0.262) #(0.215 0.262 0.285) #(0.478 0.482 0.482) #(0.921 0.921 0.929) #(0.987 0.991 0.983) #(0.956 0.956 0.956) #(0.102 0.102 0.102) #(0.69 0.717 0.717) #(0.293 0.694 0.89) #(0.027 0.58 0.87) #(0.023 0.293 0.443) #(0.18 0.184 0.199) #(0.874 0.878 0.874) #(0.858 0.858 0.858) #(0.02 0.02 0.02) #(0.811 0.858 0.882) #(0.012 0.595 0.893) #(0.0 0.595 0.893) #(0.008 0.591 0.886) #(0.02 0.242 0.369) #(0.207 0.199 0.199) #(0.948 0.948 0.948) #(0.886 0.886 0.886) #(0.035 0.031 0.027) #(0.698 0.71 0.717) #(0.141 0.638 0.886) #(0.004 0.595 0.897) #(0.008 0.587 0.89) #(0.023 0.533 0.796) #(0.016 0.039 0.063) #(0.568 0.568 0.568) #(0.983 0.983 0.983) #(0.925 0.925 0.925) #(0.694 0.694 0.694) #(0.807 0.807 0.807) #(0.63 0.63 0.63) #(0.035 0.043 0.039) #(0.345 0.349 0.333) #(0.533 0.804 0.929) #(0.004 0.595 0.893) #(0.008 0.591 0.893) #(0.012 0.595 0.905) #(0.031 0.164 0.246) #(0.188 0.196 0.192) #(0.893 0.893 0.893) #(0.192 0.192 0.192) #(0.207 0.207 0.207) #(0.012 0.012 0.012) #(0.023 0.012 0.02) #(0.016 0.086 0.129) #(0.031 0.043 0.055) #(0.427 0.595 0.702) #(0.031 0.599 0.893) #(0.008 0.587 0.897) #(0.02 0.587 0.897) #(0.016 0.254 0.365) #(0.027 0.031 0.027) #(0.466 0.466 0.466) #(0.361 0.361 0.361) #(0.341 0.341 0.341) #(0.035 0.027 0.023) #(0.408 0.423 0.427) #(0.102 0.591 0.847) #(0.027 0.529 0.804) #(0.016 0.584 0.866) #(0.016 0.587 0.878) #(0.023 0.568 0.85) #(0.023 0.58 0.862) #(0.023 0.129 0.192) #(0.063 0.063 0.063) #(0.317 0.317 0.313) #(0.423 0.419 0.415) #(0.714 0.725 0.714) #(0.714 0.714 0.71) #(0.979 0.976 0.968) #(0.239 0.674 0.905) #(0.016 0.595 0.89) #(0.023 0.564 0.862) #(0.031 0.145 0.219) #(0.02 0.027 0.047) #(0.012 0.039 0.059) #(0.431 0.431 0.431) #(0.458 0.458 0.466) #(0.133 0.199 0.231) #(0.505 0.792 0.933) #(0.741 0.886 0.956) #(0.474 0.776 0.925) #(0.035 0.587 0.882) #(0.023 0.556 0.843) #(0.027 0.188 0.278) #(0.043 0.035 0.051) #(0.435 0.439 0.435) #(0.357 0.357 0.357) #(0.619 0.619 0.619) #(0.952 0.952 0.952) #(0.792 0.8 0.804) #(0.008 0.02 0.027) #(0.023 0.478 0.725) #(0.016 0.587 0.893) #(0.023 0.595 0.89) #(0.023 0.466 0.706) #(0.016 0.094 0.141) #(0.008 0.008 0.012) #(0.02 0.012 0.012) #(0.638 0.638 0.642) #(0.991 0.991 0.991) #(0.976 0.976 0.976) #(0.168 0.164 0.164) #(0.016 0.18 0.25) #(0.008 0.58 0.874) #(0.016 0.591 0.87) #(0.031 0.156 0.239) #(0.02 0.008 0.016) #(0.012 0.012 0.02) #(0.008 0.008 0.008) #(0.258 0.258 0.258) #(0.866 0.866 0.866) #(0.051 0.047 0.047) #(0.023 0.016 0.027) #(0.027 0.258 0.388) #(0.016 0.564 0.858) #(0.016 0.435 0.654) #(0.023 0.18 0.258) #(0.016 0.016 0.016) #(0.4 0.4 0.4) #(0.039 0.039 0.039) #(0.325 0.325 0.321) #(0.035 0.031 0.039) #(0.02 0.09 0.133) #(0.031 0.188 0.289) #(0.023 0.137 0.188) #(0.016 0.027 0.043) #(0.576 0.576 0.576) #(0.16 0.16 0.16) #(0.733 0.733 0.733) #(0.753 0.749 0.749) #(0.365 0.365 0.376) #(0.117 0.113 0.121) #(0.074 0.066 0.066) #(0.203 0.203 0.219) #(0.603 0.603 0.603) #(0.979 0.979 0.979) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #(1.0 1.0 1.0) #( ) )) ]! ! !MenuTile methodsFor: 'accessing' stamp: 'sw 9/27/2001 17:28'! resultType "Answer the result type of the receiver" ^ #Menu! ! !MenuTile methodsFor: 'event handling' stamp: 'sw 10/3/2002 21:16'! mouseDown: evt | aPoint aMenu reply | aPoint _ evt cursorPoint. nArrowTicks _ 0. ((upArrow bounds containsPoint: aPoint) or: [downArrow bounds containsPoint: aPoint]) ifTrue: [^ self mouseStillDown: evt]. aMenu _ SelectionMenu selections: (((self ownerThatIsA: PhraseTileMorph) associatedPlayer costume allMenuWordings) copyWithout: ''). reply _ aMenu startUp. reply ifNotNil: [self literal: reply; layoutChanged]! ! !MenuTile methodsFor: 'initialization' stamp: 'dgd 9/6/2003 17:36'! initialize "Initialize the menu tile" super initialize. self addArrows; setLiteral: 'send to back' translated. self labelMorph useStringFormat; putSelector: nil! ! !MenuType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ MenuTile new typeColor: self typeColor! ! !MenuType methodsFor: 'tiles' stamp: 'sw 1/5/2005 22:27'! representsAType "Answer whether this vocabulary represents an end-user-sensible data type" ^false! ! !MenuType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Menu! ! !MenuType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.4 0.4 0.4) ! ! !MenuType commentStamp: 'sw 1/6/2005 03:45' prior: 0! A type associated with menu-item values. An imperfect thing thus far, only usable in the doMenuItem etoy scripting phrase.! !Message methodsFor: 'accessing' stamp: 'ajh 10/9/2001 16:32'! lookupClass ^ lookupClass! ! !Message methodsFor: 'printing' stamp: 'ajh 10/9/2001 15:31'! printOn: stream args isEmpty ifTrue: [^ stream nextPutAll: selector]. args with: selector keywords do: [:arg :word | stream nextPutAll: word. stream space. arg printOn: stream. stream space. ]. stream skip: -1. ! ! !Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! lookupClass: aClass lookupClass _ aClass! ! !Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'! setSelector: aSymbol selector _ aSymbol. ! ! !Message methodsFor: 'sending' stamp: 'ajh 1/22/2003 11:51'! sendTo: receiver "answer the result of sending this message to receiver" ^ receiver perform: selector withArguments: args! ! !Message methodsFor: 'stub creation' stamp: 'ads 7/21/2003 17:33'! createStubMethod | argNames aOrAn argName arg argClassName | argNames _ Set new. ^ String streamContents: [ :s | self selector keywords doWithIndex: [ :key :i | s nextPutAll: key. ((key last = $:) or: [self selector isInfix]) ifTrue: [ arg _ self arguments at: i. argClassName _ (arg isKindOf: Class) ifTrue: ['Class'] ifFalse: [arg class name]. aOrAn _ argClassName first isVowel ifTrue: ['an'] ifFalse: ['a']. argName _ aOrAn, argClassName. [argNames includes: argName] whileTrue: [argName _ argName, i asString]. argNames add: argName. s nextPutAll: ' '; nextPutAll: argName; space ]. ]. s cr; tab. s nextPutAll: 'self shouldBeImplemented' ]! ! !Message methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 17:37'! pushReceiver! ! !Message class methodsFor: 'instance creation' stamp: 'ajh 7/11/2001 12:05'! catcher ^ MessageCatcher new! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! doesNotUnderstand: aMessage accumulator ifNotNil: [accumulator add: aMessage]. ^ aMessage! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator ^ accumulator! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator: collection accumulator _ collection! ! !MessageCatcher commentStamp: '<historical>' prior: 0! Any message sent to me is returned as a Message object. "Message catcher" creates an instance of me. ! !MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28'! computeSelectorListFromSearchString "Compute selector list from search string" | raw sorted | searchString _ searchString asString copyWithout: $ . selectorList _ Cursor wait showWhile: [raw _ Symbol selectorsContaining: searchString. sorted _ raw as: SortedCollection. sorted sortBlock: [:x :y | x asLowercase <= y asLowercase]. sorted asArray]. selectorList size > 19 ifFalse: ["else the following filtering is considered too expensive. This 19 should be a system-maintained Parameter, someday" selectorList _ self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList]. ^ selectorList! ! !MessageNames methodsFor: 'search' stamp: 'sw 7/28/2001 00:32'! doSearchFrom: aPane "The user hit the Search button -- treat it as a synonym for the user having hit the Return or Enter (or cmd-s) in the type-in pane" aPane accept. aPane selectAll! ! !MessageNames methodsFor: 'search' stamp: 'sw 7/28/2001 00:43'! searchString "Answer the current searchString, initializing it if need be" | pane | searchString isEmptyOrNil ifTrue: [searchString _ 'type here, then hit Search'. pane _ self containingWindow findDeepSubmorphThat: [:m | m knownName = 'Search'] ifAbsent: ["this happens during window creation" ^ searchString]. pane setText: searchString. pane setTextMorphToSelectAllOnMouseEnter. pane selectAll]. ^ searchString! ! !MessageNames methodsFor: 'search' stamp: 'sw 7/28/2001 02:18'! searchString: aString notifying: aController "Take what the user typed and find all selectors containing it" searchString _ aString asString copyWithout: $ . self containingWindow setLabel: 'Message names containing "', searchString asLowercase, '"'. selectorList _ nil. self changed: #selectorList. self changed: #messageList. ^ true! ! !MessageNames methodsFor: 'search' stamp: 'sd 4/20/2003 14:28'! showOnlyImplementedSelectors "Caution -- can be slow!! Filter my selector list down such that it only shows selectors that are actually implemented somewhere in the system." self okToChange ifTrue: [Cursor wait showWhile: [selectorList _ self systemNavigation allSelectorsWithAnyImplementorsIn: selectorList. self changed: #selectorList. self changed: #messageList]]! ! !MessageNames methodsFor: 'selection' stamp: 'sw 7/24/2001 01:46'! selection "Answer the item in the list that is currently selected, or nil if no selection is present" ^ self messageList at: messageListIndex ifAbsent: [nil]! ! !MessageNames methodsFor: 'selector list' stamp: 'sd 4/19/2003 12:12'! messageList "Answer the receiver's message list, computing it if necessary. The way to force a recomputation is to set the messageList to nil" messageList ifNil: [messageList _ selectorListIndex == 0 ifTrue: [#()] ifFalse: [self systemNavigation allImplementorsOf: (selectorList at: selectorListIndex)]. self messageListIndex: (messageList size > 0 ifTrue: [1] ifFalse: [0])]. ^ messageList! ! !MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:46'! selectorList "Answer the selectorList" selectorList ifNil: [self computeSelectorListFromSearchString. selectorListIndex _ selectorList size > 0 ifTrue: [1] ifFalse: [0]. messageList _ nil]. ^ selectorList! ! !MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:55'! selectorListIndex "Answer the selectorListIndex" ^ selectorListIndex! ! !MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:59'! selectorListIndex: anInteger "Set the selectorListIndex as specified, and propagate consequences" selectorListIndex _ anInteger. selectorListIndex = 0 ifTrue: [^ self]. messageList _ nil. self changed: #selectorListIndex. self changed: #messageList! ! !MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:58'! selectorListMenu: aMenu "Answer the menu associated with the selectorList" aMenu addList: #( ('senders (n)' browseSenders 'browse senders of the chosen selector') ('copy selector to clipboard' copyName 'copy the chosen selector to the clipboard, for subsequent pasting elsewhere') - ('show only implemented selectors' showOnlyImplementedSelectors 'remove from the selector-list all symbols that do not represent implemented methods')). ^ aMenu! ! !MessageNames methodsFor: 'selector list' stamp: 'sw 7/24/2001 01:47'! selectorListMenuTitle "Answer the title to supply for the menu belonging to the selector-list pane" ^ 'Click on any item in the list to see all implementors of it'! ! !MessageNames methodsFor: 'initialization' stamp: 'sw 7/28/2001 02:16'! inMorphicWindowLabeled: labelString "Answer a morphic window with the given label that can display the receiver" "MessageNames openMessageNames" ^ self inMorphicWindowWithInitialSearchString: nil! ! !MessageNames methodsFor: 'initialization' stamp: 'nk 4/28/2004 10:18'! inMorphicWindowWithInitialSearchString: initialString "Answer a morphic window with the given initial search string, nil if none" "MessageNames openMessageNames" | window selectorListView firstDivider secondDivider horizDivider typeInPane searchButton plugTextMor | window _ (SystemWindow labelled: 'Message Names') model: self. firstDivider _ 0.07. secondDivider _ 0.5. horizDivider _ 0.5. typeInPane _ AlignmentMorph newRow vResizing: #spaceFill; height: 14. typeInPane hResizing: #spaceFill. typeInPane listDirection: #leftToRight. plugTextMor _ PluggableTextMorph on: self text: #searchString accept: #searchString:notifying: readSelection: nil menu: nil. plugTextMor setProperty: #alwaysAccept toValue: true. plugTextMor askBeforeDiscardingEdits: false. plugTextMor acceptOnCR: true. plugTextMor setTextColor: Color brown. plugTextMor setNameTo: 'Search'. plugTextMor vResizing: #spaceFill; hResizing: #spaceFill. plugTextMor hideScrollBarsIndefinitely. plugTextMor setTextMorphToSelectAllOnMouseEnter. searchButton _ SimpleButtonMorph new target: self; beTransparent; label: 'Search'; actionSelector: #doSearchFrom:; arguments: {plugTextMor}. searchButton setBalloonText: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.'. typeInPane addMorphFront: searchButton. typeInPane addTransparentSpacerOfSize: 6@0. typeInPane addMorphBack: plugTextMor. initialString isEmptyOrNil ifFalse: [plugTextMor setText: initialString]. window addMorph: typeInPane frame: (0@0 corner: horizDivider @ firstDivider). selectorListView _ PluggableListMorph on: self list: #selectorList selected: #selectorListIndex changeSelected: #selectorListIndex: menu: #selectorListMenu: keystroke: #selectorListKey:from:. selectorListView menuTitleSelector: #selectorListMenuTitle. window addMorph: selectorListView frame: (0 @ firstDivider corner: horizDivider @ secondDivider). window addMorph: self buildMorphicMessageList frame: (horizDivider @ 0 corner: 1@ secondDivider). self addLowerPanesTo: window at: (0 @ secondDivider corner: 1@1) with: nil. initialString isEmptyOrNil ifFalse: [self searchString: initialString notifying: nil]. ^ window! ! !MessageNames methodsFor: 'initialization' stamp: 'sw 7/24/2001 01:35'! selectorListKey: aChar from: view "Respond to a Command key in the message-list pane." aChar == $n ifTrue: [^ self browseSenders]. aChar == $c ifTrue: [^ self copyName]. aChar == $b ifTrue: [^ self browseMethodFull]. ! ! !MessageNames methodsFor: 'message list menu' stamp: 'sw 8/15/2002 17:24'! copyName "Copy the current selector to the clipboard" | selector | (selector _ self selectorList at: selectorListIndex ifAbsent: [nil]) ifNotNil: [Clipboard clipboardText: selector asString asText]! ! !MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/28/2001 00:54'! methodBrowserSearchingFor: searchString "Answer an method-browser window whose search-string is initially as indicated" | aWindow | aWindow _ self new inMorphicWindowWithInitialSearchString: searchString. aWindow applyModelExtent. ^ aWindow! ! !MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/24/2001 18:03'! openMessageNames "Open a new instance of the receiver in the active world" self new openAsMorphNamed: 'Message Names' inWorld: ActiveWorld "MessageNames openMessageNames" ! ! !MessageNames class methodsFor: 'instance creation' stamp: 'sw 7/28/2001 00:56'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" ^ self methodBrowserSearchingFor: nil! ! !MessageNames class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:35'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Message Names' brightColor: #(0.645 1.0 0.452) pastelColor: #(0.843 0.976 0.843) helpMessage: 'A tool finding, viewing, and editing all methods whose names contiane a given character sequence.'! ! !MessageNames class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:53'! initialize self registerInFlapsRegistry. ! ! !MessageNames class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 12:53'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(MessageNames prototypicalToolWindow 'Message Names' 'A tool for finding, viewing, and editing all methods whose names contain a given character sequence.') forFlapNamed: 'Tools']! ! !MessageNames class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:37'! unload "Unload the receiver from global registries" self environment at: #FileList ifPresent: [:cl | cl unregisterFileReader: self]. self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !MessageNode methodsFor: 'initialize-release' stamp: 'md 10/20/2004 15:32'! receiver: rcvr selector: aSelector arguments: args precedence: p from: encoder "Compile." | theSelector | self receiver: rcvr arguments: args precedence: p. aSelector = #':Repeat:do:' ifTrue: [theSelector _ #do:] ifFalse: [theSelector _ aSelector]. self noteSpecialSelector: theSelector. (self transform: encoder) ifTrue: [selector isNil ifTrue: [selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro]] ifFalse: [selector _ encoder encodeSelector: theSelector. rcvr == NodeSuper ifTrue: [encoder noteSuper]]. self pvtCheckForPvtSelector: encoder! ! !MessageNode methodsFor: 'macro transformations' stamp: 'hmm 7/15/2001 22:22'! transformToDo: encoder " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: " | limit increment block initStmt test incStmt limitInit blockVar myRange blockRange | "First check for valid arguments" ((arguments last isMemberOf: BlockNode) and: [arguments last numberOfArguments = 1]) ifFalse: [^ false]. arguments last firstArgument isVariableReference ifFalse: [^ false]. "As with debugger remote vars" arguments size = 3 ifTrue: [increment _ arguments at: 2. (increment isConstantNumber and: [increment literalValue ~= 0]) ifFalse: [^ false]] ifFalse: [increment _ encoder encodeLiteral: 1]. arguments size < 3 ifTrue: "transform to full form" [selector _ SelectorNode new key: #to:by:do: code: #macro]. "Now generate auxiliary structures" myRange _ encoder rawSourceRanges at: self ifAbsent: [1 to: 0]. block _ arguments last. blockRange _ encoder rawSourceRanges at: block ifAbsent: [1 to: 0]. blockVar _ block firstArgument. initStmt _ AssignmentNode new variable: blockVar value: receiver. limit _ arguments at: 1. limit isVariableReference | limit isConstantNumber ifTrue: [limitInit _ nil] ifFalse: "Need to store limit in a var" [limit _ encoder autoBind: blockVar key , 'LimiT'. limit scope: -2. "Already done parsing block" limitInit _ AssignmentNode new variable: limit value: (arguments at: 1)]. test _ MessageNode new receiver: blockVar selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) arguments: (Array with: limit) precedence: precedence from: encoder sourceRange: (myRange first to: blockRange first). incStmt _ AssignmentNode new variable: blockVar value: (MessageNode new receiver: blockVar selector: #+ arguments: (Array with: increment) precedence: precedence from: encoder) from: encoder sourceRange: (myRange last to: myRange last). arguments _ (Array with: limit with: increment with: block) , (Array with: initStmt with: test with: incStmt with: limitInit). ^ true! ! !MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:39'! emitForEffect: stack on: strm "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." special > 0 ifTrue: [pc _ 0. self perform: (MacroEmitters at: special) with: stack with: strm with: false] ifFalse: [super emitForEffect: stack on: strm]! ! !MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:40'! emitForValue: stack on: strm "For #ifTrue:ifFalse: and #whileTrue: / #whileFalse: style messages, the pc is set to the jump instruction, so that mustBeBoolean exceptions can be shown correctly." special > 0 ifTrue: [pc _ 0. self perform: (MacroEmitters at: special) with: stack with: strm with: true] ifFalse: [receiver ~~ nil ifTrue: [receiver emitForValue: stack on: strm]. arguments do: [:argument | argument emitForValue: stack on: strm]. selector emit: stack args: arguments size on: strm super: receiver == NodeSuper. pc _ strm position]! ! !MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:23'! emitIf: stack on: strm value: forValue | thenExpr thenSize elseExpr elseSize | thenSize _ sizes at: 1. elseSize _ sizes at: 2. (forValue not and: [(elseSize*thenSize) > 0]) ifTrue: "Two-armed IFs forEffect share a single pop" [^ super emitForEffect: stack on: strm]. thenExpr _ arguments at: 1. elseExpr _ arguments at: 2. receiver emitForValue: stack on: strm. forValue ifTrue: "Code all forValue as two-armed" [self emitBranchOn: false dist: thenSize pop: stack on: strm. pc _ strm position. thenExpr emitForEvaluatedValue: stack on: strm. stack pop: 1. "then and else alternate; they don't accumulate" thenExpr returns not ifTrue: "Elide jump over else after a return" [self emitJump: elseSize on: strm]. elseExpr emitForEvaluatedValue: stack on: strm] ifFalse: "One arm is empty here (two-arms code forValue)" [thenSize > 0 ifTrue: [self emitBranchOn: false dist: thenSize pop: stack on: strm. pc _ strm position. thenExpr emitForEvaluatedEffect: stack on: strm] ifFalse: [self emitBranchOn: true dist: elseSize pop: stack on: strm. pc _ strm position. elseExpr emitForEvaluatedEffect: stack on: strm]]! ! !MessageNode methodsFor: 'code generation' stamp: 'ajh 7/31/2003 11:26'! emitIfNil: stack on: strm value: forValue | theNode theSize theSelector | theNode _ arguments first. theSize _ sizes at: 1. theSelector _ #ifNotNil:. receiver emitForValue: stack on: strm. forValue ifTrue: [strm nextPut: Dup. stack push: 1]. strm nextPut: LdNil. stack push: 1. equalNode emit: stack args: 1 on: strm. self emitBranchOn: (selector key == theSelector) dist: theSize pop: stack on: strm. pc _ strm position. forValue ifTrue: [strm nextPut: Pop. stack pop: 1. theNode emitForEvaluatedValue: stack on: strm] ifFalse: [theNode emitForEvaluatedEffect: stack on: strm].! ! !MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:42'! emitToDo: stack on: strm value: forValue " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: " | loopSize initStmt limitInit test block incStmt blockSize | initStmt _ arguments at: 4. limitInit _ arguments at: 7. test _ arguments at: 5. block _ arguments at: 3. incStmt _ arguments at: 6. blockSize _ sizes at: 1. loopSize _ sizes at: 2. limitInit == nil ifFalse: [limitInit emitForEffect: stack on: strm]. initStmt emitForEffect: stack on: strm. test emitForValue: stack on: strm. self emitBranchOn: false dist: blockSize pop: stack on: strm. pc _ strm position. block emitForEvaluatedEffect: stack on: strm. incStmt emitForEffect: stack on: strm. self emitJump: 0 - loopSize on: strm. forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! ! !MessageNode methodsFor: 'code generation' stamp: 'hmm 7/28/2001 14:36'! emitWhile: stack on: strm value: forValue " L1: ... Bfp(L2)|Btp(L2) ... Jmp(L1) L2: " | cond stmt stmtSize loopSize | cond _ receiver. stmt _ arguments at: 1. stmtSize _ sizes at: 1. loopSize _ sizes at: 2. cond emitForEvaluatedValue: stack on: strm. self emitBranchOn: (selector key == #whileFalse:) "Bfp for whileTrue" dist: stmtSize pop: stack on: strm. "Btp for whileFalse" pc _ strm position. stmt emitForEvaluatedEffect: stack on: strm. self emitJump: 0 - loopSize on: strm. forValue ifTrue: [strm nextPut: LdNil. stack push: 1]! ! !MessageNode methodsFor: 'printing' stamp: 'RAA 2/15/2001 19:25'! macroPrinter special > 0 ifTrue: [^MacroPrinters at: special]. ^nil ! ! !MessageNode methodsFor: 'printing' stamp: 'RAA 2/16/2001 15:12'! printIfOn: aStream indent: level aStream dialect = #SQ00 ifTrue: ["Convert to if-then-else" (arguments last isJust: NodeNil) ifTrue: [aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test ']. self printParenReceiver: receiver on: aStream indent: level + 1. ^ self printKeywords: #Yes: arguments: (Array with: arguments first) on: aStream indent: level prefix: true]. (arguments last isJust: NodeFalse) ifTrue: [self printReceiver: receiver on: aStream indent: level. ^ self printKeywords: #and: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments first isJust: NodeNil) ifTrue: [aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test ']. self printParenReceiver: receiver on: aStream indent: level + 1. ^ self printKeywords: #No: arguments: (Array with: arguments last) on: aStream indent: level prefix: true]. (arguments first isJust: NodeTrue) ifTrue: [self printReceiver: receiver on: aStream indent: level. ^ self printKeywords: #or: arguments: (Array with: arguments last) on: aStream indent: level]. aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Test ']. self printParenReceiver: receiver on: aStream indent: level + 1. ^ self printKeywords: #Yes:No: arguments: arguments on: aStream indent: level prefix: true]. receiver ifNotNil: [ receiver printOn: aStream indent: level + 1 precedence: precedence. ]. (arguments last isJust: NodeNil) ifTrue: [^ self printKeywords: #ifTrue: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments last isJust: NodeFalse) ifTrue: [^ self printKeywords: #and: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments first isJust: NodeNil) ifTrue: [^ self printKeywords: #ifFalse: arguments: (Array with: arguments last) on: aStream indent: level]. (arguments first isJust: NodeTrue) ifTrue: [^ self printKeywords: #or: arguments: (Array with: arguments last) on: aStream indent: level]. self printKeywords: #ifTrue:ifFalse: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'RAA 2/16/2001 15:12'! printOn: aStream indent: level | leadingKeyword | "may not need this check anymore - may be fixed by the #receiver: change" special ifNil: [^aStream nextPutAll: '** MessageNode with nil special **']. (special > 0) ifTrue: [self perform: self macroPrinter with: aStream with: level] ifFalse: [selector key first = $: ifTrue: [leadingKeyword _ selector key keywords first. aStream nextPutAll: leadingKeyword; space. self printReceiver: receiver on: aStream indent: level. self printKeywords: (selector key allButFirst: leadingKeyword size + 1) arguments: arguments on: aStream indent: level] ifFalse: [(aStream dialect = #SQ00 and: [selector key == #do:]) ifTrue: ["Add prefix keyword" aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: 'Repeat ']. self printParenReceiver: receiver on: aStream indent: level + 1. self printKeywords: selector key arguments: arguments on: aStream indent: level prefix: true] ifFalse: [self printReceiver: receiver on: aStream indent: level. self printKeywords: selector key arguments: arguments on: aStream indent: level]]]! ! !MessageNode methodsFor: 'printing' stamp: 'nk 9/7/2004 12:34'! printWhileOn: aStream indent: level aStream dialect = #SQ00 ifTrue: ["Add prefix keyword" aStream withStyleFor: #prefixKeyword do: [aStream nextPutAll: (selector key == #whileTrue: ifTrue: ['While '] ifFalse: ['Until '])]. self printParenReceiver: receiver on: aStream indent: level + 1. self printKeywords: #do: arguments: arguments on: aStream indent: level prefix: true] ifFalse: [self printReceiver: receiver on: aStream indent: level. (arguments isEmpty not and: [ arguments first isJust: NodeNil]) ifTrue: [selector _ SelectorNode new key: (selector key == #whileTrue: ifTrue: [#whileTrue] ifFalse: [#whileFalse]) code: #macro. arguments _ Array new]. self printKeywords: selector key arguments: arguments on: aStream indent: level]! ! !MessageNode methodsFor: 'private' stamp: 'hg 10/2/2001 21:08'! checkBlock: node as: nodeName from: encoder node canBeSpecialArgument ifTrue: [^node isMemberOf: BlockNode]. ((node isKindOf: BlockNode) and: [node numberOfArguments > 0]) ifTrue: [^encoder notify: '<- ', nodeName , ' of ' , (MacroSelectors at: special) , ' must be a 0-argument block'] ifFalse: [^encoder notify: '<- ', nodeName , ' of ' , (MacroSelectors at: special) , ' must be a block or variable']! ! !MessageNode methodsFor: 'equation translation' stamp: 'RAA 2/14/2001 14:07'! receiver: val "14 feb 2001 - removed return arrow" receiver _ val! ! !MessageNode methodsFor: 'tiles' stamp: 'RAA 2/15/2001 19:34'! asMorphicSyntaxIn: parent ^parent vanillaMessageNode: self receiver: receiver selector: selector arguments: arguments ! ! !MessageNode methodsFor: 'tiles' stamp: 'RAA 2/14/2001 22:26'! morphFromKeywords: key arguments: args on: parent indent: ignored ^parent messageNode: self receiver: receiver selector: selector keywords: key arguments: args ! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'pnm 8/16/2000 15:03'! message: aMessage message := aMessage! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ab 8/22/2003 11:56'! messageText "Return an exception's message text." ^messageText == nil ifTrue: [message == nil ifTrue: [super messageText] ifFalse: [message lookupClass printString, '>>', message selector asString]] ifFalse: [messageText]! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'ajh 10/9/2001 16:38'! receiver: obj receiver _ obj! ! !MessageNotUnderstood methodsFor: 'exceptionDescription' stamp: 'ajh 10/9/2001 16:39'! receiver "Answer the receiver that did not understand the message" ^ receiver! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! arguments ^ arguments! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'! arguments: anArray arguments _ anArray! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver ^ receiver! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver: anObject receiver _ anObject! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector ^ selector! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector: aSymbol selector _ aSymbol! ! !MessageSend methodsFor: 'comparing' stamp: 'sma 2/29/2000 20:43'! = anObject ^ anObject species == self species and: [receiver == anObject receiver and: [selector == anObject selector and: [arguments = anObject arguments]]]! ! !MessageSend methodsFor: 'comparing' stamp: 'sma 3/11/2000 10:35'! hash ^ receiver hash bitXor: selector hash! ! !MessageSend methodsFor: 'evaluating' stamp: 'sw 2/20/2002 22:17'! value "Send the message and answer the return value" arguments ifNil: [^ receiver perform: selector]. ^ receiver perform: selector withArguments: (self collectArguments: arguments)! ! !MessageSend methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 16:51'! valueWithArguments: anArray ^ receiver perform: selector withArguments: (self collectArguments: anArray)! ! !MessageSend methodsFor: 'tiles' stamp: 'tk 9/28/2001 13:41'! asTilesIn: playerClass globalNames: makeSelfGlobal | code keywords num tree syn block phrase | "Construct SyntaxMorph tiles for me. If makeSelfGlobal is true, name the receiver and use that name, else use 'self'. (Note that this smashes 'self' into the receiver, regardless of what it was.)" "This is really cheating!! Make a true parse tree later. -tk" code _ String streamContents: [:strm | strm nextPutAll: 'doIt'; cr; tab. strm nextPutAll: (makeSelfGlobal ifTrue: [self stringFor: receiver] ifFalse: ['self']). keywords _ selector keywords. strm space; nextPutAll: keywords first. (num _ selector numArgs) > 0 ifTrue: [strm space. strm nextPutAll: (self stringFor: arguments first)]. 2 to: num do: [:kk | strm space; nextPutAll: (keywords at: kk). strm space; nextPutAll: (self stringFor: (arguments at: kk))]]. "decompile to tiles" tree _ Compiler new parse: code in: playerClass notifying: nil. syn _ tree asMorphicSyntaxUsing: SyntaxMorph. block _ syn submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == BlockNode] ifFalse: [false]]. phrase _ block submorphs detect: [:mm | (mm respondsTo: #parseNode) ifTrue: [ mm parseNode class == MessageNode] ifFalse: [false]]. ^ phrase ! ! !MessageSend methodsFor: 'tiles' stamp: 'sw 6/20/2001 14:17'! stringFor: anObject "Return a string suitable for compiling. Literal or reference from global ref dictionary. self is always named via the ref dictionary." | generic aName | anObject isLiteral ifTrue: [^ anObject printString]. anObject class == Color ifTrue: [^ anObject printString]. anObject class superclass == Boolean ifTrue: [^ anObject printString]. anObject class == BlockContext ifTrue: [^ '[''do nothing'']']. "default block" "Real blocks need to construct tiles in a different way" anObject class isMeta ifTrue: ["a class" ^ anObject name]. generic _ anObject knownName. "may be nil or 'Ellipse' " aName _ anObject uniqueNameForReference. generic ifNil: [(anObject respondsTo: #renameTo:) ifTrue: [anObject renameTo: aName] ifFalse: [aName _ anObject storeString]]. "for Fraction, LargeInt, etc" ^ aName ! ! !MessageSend methodsFor: 'printing' stamp: 'SqR 7/14/2001 11:36'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(. selector printOn: aStream. aStream nextPutAll: ' -> '. receiver printOn: aStream. aStream nextPut: $)! ! !MessageSend methodsFor: 'private' stamp: 'reThink 2/18/2001 17:33'! collectArguments: anArgArray "Private" | staticArgs | staticArgs := self arguments. ^(anArgArray size = staticArgs size) ifTrue: [anArgArray] ifFalse: [(staticArgs isEmpty ifTrue: [ staticArgs := Array new: selector numArgs] ifFalse: [staticArgs copy] ) replaceFrom: 1 to: (anArgArray size min: staticArgs size) with: anArgArray startingAt: 1]! ! !MessageSend methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^true ! ! !MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'! isValid ^true! ! !MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'! asMinimalRepresentation ^self! ! !MessageSend commentStamp: '<historical>' prior: 0! Instances of MessageSend encapsulate message sends to objects. Arguments can be either predefined or supplied when the message send is performed. MessageSends are used to implement the #when:send:to: event system. Use #value to perform a message send with its predefined arguments and #valueWithArguments: if additonal arguments have to supplied. Structure: receiver Object -- object receiving the message send selector Symbol -- message selector arguments Array -- bound arguments! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! receiver: anObject selector: aSymbol ^ self receiver: anObject selector: aSymbol arguments: #()! ! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:44'! receiver: anObject selector: aSymbol argument: aParameter ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! ! !MessageSend class methodsFor: 'instance creation' stamp: 'sma 2/29/2000 20:39'! receiver: anObject selector: aSymbol arguments: anArray ^ self new receiver: anObject; selector: aSymbol; arguments: anArray! ! !MessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 22:39'! addExtraShiftedItemsTo: aMenu "The shifted selector-list menu is being built. Add items specific to MessageSet" self growable ifTrue: [aMenu addList: #( - ('remove from this browser' removeMessageFromBrowser) ('filter message list...' filterMessageList) ('add to message list...' augmentMessageList))]. aMenu add: 'sort by date' action: #sortByDate! ! !MessageSet methodsFor: 'message list' stamp: 'tk 5/1/2001 18:14'! addItem: classAndMethod "Append a classAndMethod string to the list. Select the new item." "Do some checks on the input?" self okToChange ifFalse: [^ self]. messageList add: classAndMethod. self changed: #messageList. self messageListIndex: messageList size.! ! !MessageSet methodsFor: 'message list' stamp: 'nk 2/14/2004 15:10'! messageListIndex: anInteger "Set the index of the selected item to be anInteger." messageListIndex _ anInteger. contents _ messageListIndex ~= 0 ifTrue: [self selectedMessage] ifFalse: ['']. self changed: #messageListIndex. "update my selection" self editSelection: #editMessage. self contentsChanged. (messageListIndex ~= 0 and: [autoSelectString notNil]) ifTrue: [self changed: #autoSelect]. self decorateButtons ! ! !MessageSet methodsFor: 'message list' stamp: 'sw 8/1/2002 18:18'! sortByDate "Sort the message-list by date of time-stamp" | assocs aCompiledMethod aDate inOrder | assocs _ messageList collect: [:aRef | aDate _ aRef methodSymbol == #Comment ifTrue: [aRef actualClass organization dateCommentLastSubmitted] ifFalse: [aCompiledMethod _ aRef actualClass compiledMethodAt: aRef methodSymbol ifAbsent: [nil]. aCompiledMethod ifNotNil: [aCompiledMethod dateMethodLastSubmitted]]. aRef -> (aDate ifNil: [Date fromString: '01/01/1996'])]. "The dawn of Squeak history" inOrder _ assocs asSortedCollection: [:a :b | a value < b value]. messageList _ inOrder asArray collect: [:assoc | assoc key]. self changed: #messageList! ! !MessageSet methodsFor: 'message functions' stamp: 'nk 6/26/2003 21:44'! removeMessage "Remove the selected message from the system. 1/15/96 sw" | messageName confirmation | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. confirmation _ self systemNavigation confirmRemovalOf: messageName on: self selectedClassOrMetaClass. confirmation == 3 ifTrue: [^ self]. self selectedClassOrMetaClass removeSelector: messageName. self deleteFromMessageList: self selection. self reformulateList. confirmation == 2 ifTrue: [self systemNavigation browseAllCallsOn: messageName]! ! !MessageSet methodsFor: 'contents' stamp: 'di 10/1/2001 22:26'! contents "Answer the contents of the receiver" ^ contents == nil ifTrue: [currentCompiledMethod _ nil. ''] ifFalse: [messageListIndex = 0 ifTrue: [currentCompiledMethod _ nil. contents] ifFalse: [self showingByteCodes ifTrue: [self selectedBytecodes] ifFalse: [self selectedMessage]]]! ! !MessageSet methodsFor: 'contents' stamp: 'nk 6/19/2004 16:47'! selectedMessage "Answer the source method for the currently selected message." | source | self setClassAndSelectorIn: [:class :selector | class ifNil: [^ 'Class vanished']. selector first isUppercase ifTrue: [selector == #Comment ifTrue: [currentCompiledMethod _ class organization commentRemoteStr. ^ class comment]. selector == #Definition ifTrue: [^ class definitionST80: Preferences printAlternateSyntax not]. selector == #Hierarchy ifTrue: [^ class printHierarchy]]. source _ class sourceMethodAt: selector ifAbsent: [currentCompiledMethod _ nil. ^ 'Missing']. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil]. self showingDocumentation ifTrue: [^ self commentContents]. source _ self sourceStringPrettifiedAndDiffed. ^ source asText makeSelectorBoldIn: class]! ! !MessageSet methodsFor: 'contents' stamp: 'sw 2/14/2001 15:25'! setContentsToForceRefetch "Set the receiver's contents such that on the next update the contents will be formulated afresh. This is a critical and obscure difference between Browsers on the one hand and MessageSets on the other, and has over the years been the source of much confusion and much difficulty. By centralizing the different handling here, we don't need so many idiosyncratic overrides in MessageSet any more" contents _ ''! ! !MessageSet methodsFor: 'private' stamp: 'sw 6/6/2001 13:30'! buildMorphicMessageList "Build my message-list object in morphic" | aListMorph | aListMorph _ PluggableListMorph new. aListMorph setProperty: #highlightSelector toValue: #highlightMessageList:with:; setProperty: #itemConversionMethod toValue: #asStringOrText; setProperty: #balloonTextSelectorForSubMorphs toValue: #balloonTextForClassAndMethodString. aListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph enableDragNDrop: Preferences browseWithDragNDrop. aListMorph menuTitleSelector: #messageListSelectorTitle. ^ aListMorph ! ! !MessageSet methodsFor: 'private' stamp: 'sw 7/31/2002 12:58'! contents: aString notifying: aController "Compile the code in aString. Notify aController of any syntax errors. Answer false if the compilation fails. Otherwise, if the compilation created a new method, deselect the current selection. Then answer true." | category selector class oldSelector | self okayToAccept ifFalse: [^ false]. self setClassAndSelectorIn: [:c :os | class _ c. oldSelector _ os]. class ifNil: [^ false]. (oldSelector ~~ nil and: [oldSelector first isUppercase]) ifTrue: [oldSelector = #Comment ifTrue: [class comment: aString stamp: Utilities changeStamp. self changed: #annotation. self clearUserEditFlag. ^ false]. oldSelector = #Definition ifTrue: ["self defineClass: aString notifying: aController." class subclassDefinerClass evaluate: aString notifying: aController logged: true. self clearUserEditFlag. ^ false]. oldSelector = #Hierarchy ifTrue: [self inform: 'To change the hierarchy, edit the class definitions'. ^ false]]. "Normal method accept" category _ class organization categoryOfElement: oldSelector. selector _ class compile: aString classified: category notifying: aController. selector == nil ifTrue: [^ false]. self noteAcceptanceOfCodeFor: selector. selector == oldSelector ifFalse: [self reformulateListNoting: selector]. contents _ aString copy. self changed: #annotation. ^ true! ! !MessageSet methodsFor: 'private' stamp: 'sw 6/12/2001 21:07'! inMorphicWindowLabeled: labelString "Answer a morphic window with the given label that can display the receiver" | window listFraction | window _ (SystemWindow labelled: labelString) model: self. listFraction _ 0.2. window addMorph: self buildMorphicMessageList frame: (0@0 extent: 1@listFraction). self addLowerPanesTo: window at: (0@listFraction corner: 1@1) with: nil. window setUpdatablePanesFrom: #(messageList). ^ window! ! !MessageSet methodsFor: 'private' stamp: 'yo 12/3/2004 17:23'! initializeMessageList: anArray "Initialize my messageList from the given list of MethodReference or string objects. NB: special handling for uniclasses." | s | messageList _ OrderedCollection new. anArray do: [ :each | MessageSet parse: each toClassAndSelector: [ :class :sel | class ifNotNil: [class isUniClass ifTrue: [s _ class typicalInstanceName, ' ', sel] ifFalse: [s _ class name , ' ' , sel , ' {' , ((class organization categoryOfElement: sel) ifNil: ['']) , '}']. messageList add: ( MethodReference new setClass: class methodSymbol: sel stringVersion: s)]]]. messageListIndex _ messageList isEmpty ifTrue: [0] ifFalse: [1]. contents _ ''! ! !MessageSet methodsFor: 'private' stamp: 'yo 7/30/2004 16:36'! openAsMorphNamed: labelString inWorld: aWorld "Open the receiver in a morphic window in the given world" (self inMorphicWindowLabeled: labelString) openInWorld: aWorld. self messageListIndex: 1. ! ! !MessageSet methodsFor: 'private' stamp: 'RAA 5/29/2001 10:12'! setClassAndSelectorIn: csBlock | sel | "Decode strings of the form <className> [class] <selectorName>." self flag: #mref. "compatibility with pre-MethodReference lists" sel _ self selection. ^(sel isKindOf: MethodReference) ifTrue: [ sel setClassAndSelectorIn: csBlock ] ifFalse: [ MessageSet parse: sel toClassAndSelector: csBlock ]! ! !MessageSet methodsFor: 'filtering' stamp: 'nk 9/7/2004 11:54'! filterFrom: aBlock "Filter the receiver's list down to only those items that satisfy aBlock, which takes a class an a selector as its arguments." | newList | newList _ messageList select: [:anElement | self class parse: anElement toClassAndSelector: [ :cls :sel | (self class isPseudoSelector: sel) not and: [ aBlock value: cls value: sel ]]]. self setFilteredList: newList! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/12/2001 13:12'! filterMessageList "Allow the user to refine the list of messages." | aMenu evt | Smalltalk isMorphic ifFalse: [^ self inform: 'sorry, morphic only at this time.']. messageList size <= 1 ifTrue: [^ self inform: 'this is not a propitious filtering situation']. "would like to get the evt coming in but thwarted by the setInvokingView: circumlocution" evt _ self currentWorld activeHand lastEvent. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Filter by only showing...'. aMenu addStayUpItem. aMenu addList: #( ('unsent messages' filterToUnsentMessages 'filter to show only messages that have no senders') - ('messages that send...' filterToSendersOf 'filter to show only messages that send a selector I specify') ('messages that do not send...' filterToNotSendersOf 'filter to show only messages that do not send a selector I specify') - ('messages whose selector is...' filterToImplementorsOf 'filter to show only messages with a given selector I specify') ('messages whose selector is NOT...' filterToNotImplementorsOf 'filter to show only messages whose selector is NOT a seletor I specify') - ('messages in current change set' filterToCurrentChangeSet 'filter to show only messages that are in the current change set') ('messages not in current change set' filterToNotCurrentChangeSet 'filter to show only messages that are not in the current change set') - ('messages in any change set' filterToAnyChangeSet 'filter to show only messages that occur in at least one change set') ('messages not in any change set' filterToNotAnyChangeSet 'filter to show only messages that do not occur in any change set in the system') - ('messages authored by me' filterToCurrentAuthor 'filter to show only messages whose authoring stamp has my initials') ('messages not authored by me' filterToNotCurrentAuthor 'filter to show only messages whose authoring stamp does not have my initials') - ('messages logged in .changes file' filterToMessagesInChangesFile 'filter to show only messages whose latest source code is logged in the .changes file') ('messages only in .sources file' filterToMessagesInSourcesFile 'filter to show only messages whose latest source code is logged in the .sources file') - ('messages with prior versions' filterToMessagesWithPriorVersions 'filter to show only messages that have at least one prior version') ('messages without prior versions' filterToMessagesWithoutPriorVersions 'filter to show only messages that have no prior versions') - ('uncommented messages' filterToUncommentedMethods 'filter to show only messages that do not have comments at the beginning') ('commented messages' filterToCommentedMethods 'fileter to show only messages that have comments at the beginning') - ('messages in hardened classes' filterToMessagesWithHardenedClasses 'filter to show only messages of established classes (as opposed to Uniclasses such as Player23)') - ('messages that...' filterToMessagesThat 'let me type in a block taking a class and a selector, which will specify yea or nay concerning which elements should remain in the list') ). aMenu popUpEvent: evt hand lastEvent in: evt hand world.! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 12:55'! filterToAnyChangeSet "Filter down only to messages present in ANY change set" self filterFrom: [:aClass :aSelector | ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector] ! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:45'! filterToCommentedMethods "Filter the receiver's list down to only those items which have comments" self filterFrom: [:aClass :aSelector | (aClass selectors includes: aSelector) and: [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil not]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 2/14/2001 18:30'! filterToCurrentAuthor "Filter down only to messages with my initials as most recent author" | myInitials aMethod aTimeStamp | (myInitials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [aMethod _ aClass compiledMethodAt: aSelector ifAbsent: [nil]. aMethod notNil and: [(aTimeStamp _ Utilities timeStampForMethod: aMethod) notNil and: [aTimeStamp beginsWith: myInitials]]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'! filterToCurrentChangeSet "Filter the receiver's list down to only those items in the current change set" self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [(ChangeSet current atSelector: aSelector class: aClass) ~~ #none]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:33'! filterToImplementorsOf "Filter the receiver's list down to only those items with a given selector" | aFragment inputWithBlanksTrimmed | aFragment _ FillInTheBlank request: 'type selector:' initialAnswer: ''. aFragment isEmptyOrNil ifTrue: [^ self]. inputWithBlanksTrimmed _ aFragment withBlanksTrimmed. Symbol hasInterned: inputWithBlanksTrimmed ifTrue: [:aSymbol | self filterFrom: [:aClass :aSelector | aSelector == aSymbol]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 15:14'! filterToMessagesInChangesFile "Filter down only to messages whose source code risides in the Changes file. This allows one to ignore long-standing methods that live in the .sources file." | cm | self filterFrom: [:aClass :aSelector | aClass notNil and: [aSelector notNil and: [(self class isPseudoSelector: aSelector) not and: [(cm _ aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: [cm fileIndex ~~ 1]]]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 15:15'! filterToMessagesInSourcesFile "Filter down only to messages whose source code resides in the .sources file." | cm | self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [(self class isPseudoSelector: aSelector) not and: [(cm _ aClass compiledMethodAt: aSelector ifAbsent: [nil]) notNil and: [cm fileIndex == 1]]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 14:10'! filterToMessagesThat "Allow the user to type in a block which will be" | reply | reply _ FillInTheBlank multiLineRequest: 'Type your block here' centerAt: Sensor cursorPoint initialAnswer: '[:aClass :aSelector | ]' answerHeight: 200. reply isEmptyOrNil ifTrue: [^ self]. self filterFrom: (Compiler evaluate: reply) ! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 2/13/2001 12:02'! filterToMessagesWithHardenedClasses "Filter the receiver's list down to only those items representing methods of hardened classes, as opposed to uniclasses" self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [aClass isUniClass not]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/12/2001 22:25'! filterToMessagesWithPriorVersions "Filter down only to messages which have at least one prior version" self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [(self class isPseudoSelector: aSelector) not and: [(VersionsBrowser versionCountForSelector: aSelector class: aClass) > 1]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 15:12'! filterToMessagesWithoutPriorVersions "Filter down only to messages which have no prior version stored" self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [(self class isPseudoSelector: aSelector) not and: [(VersionsBrowser versionCountForSelector: aSelector class: aClass) <= 1]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 6/6/2001 13:07'! filterToNotAnyChangeSet "Filter down only to messages present in NO change set" self filterFrom: [:aClass :aSelector | (ChangeSorter doesAnyChangeSetHaveClass: aClass andSelector: aSelector) not] ! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 2/14/2001 18:24'! filterToNotCurrentAuthor "Filter down only to messages not stamped with my initials" | myInitials aMethod aTimeStamp | (myInitials _ Utilities authorInitialsPerSe) ifNil: [^ self inform: 'No author initials set in this image']. self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [aMethod _ aClass compiledMethodAt: aSelector ifAbsent: [nil]. aMethod notNil and: [(aTimeStamp _ Utilities timeStampForMethod: aMethod) isNil or: [(aTimeStamp beginsWith: myInitials) not]]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sd 5/23/2003 14:38'! filterToNotCurrentChangeSet "Filter the receiver's list down to only those items not in the current change set" self filterFrom: [:aClass :aSelector | (aClass notNil and: [aSelector notNil]) and: [(ChangeSet current atSelector: aSelector class: aClass) == #none]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:34'! filterToNotImplementorsOf "Filter the receiver's list down to only those items whose selector is NOT one solicited from the user." | aFragment inputWithBlanksTrimmed | aFragment _ FillInTheBlank request: 'type selector: ' initialAnswer: ''. aFragment isEmptyOrNil ifTrue: [^ self]. inputWithBlanksTrimmed _ aFragment withBlanksTrimmed. Symbol hasInterned: inputWithBlanksTrimmed ifTrue: [:aSymbol | self filterFrom: [:aClass :aSelector | aSelector ~~ aSymbol]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/12/2001 13:11'! filterToNotSendersOf "Filter the receiver's list down to only those items which do not send a given selector" | aFragment inputWithBlanksTrimmed aMethod | aFragment _ FillInTheBlank request: 'type selector:' initialAnswer: ''. aFragment isEmptyOrNil ifTrue: [^ self]. inputWithBlanksTrimmed _ aFragment withBlanksTrimmed. Symbol hasInterned: inputWithBlanksTrimmed ifTrue: [:aSymbol | self filterFrom: [:aClass :aSelector | (aMethod _ aClass compiledMethodAt: aSelector) isNil or: [(aMethod hasLiteralThorough: aSymbol) not]]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sw 8/10/2001 14:43'! filterToUncommentedMethods "Filter the receiver's list down to only those items which lack comments" self filterFrom: [:aClass :aSelector | (aClass selectors includes: aSelector) and: [(aClass firstPrecodeCommentFor: aSelector) isEmptyOrNil]]! ! !MessageSet methodsFor: 'filtering' stamp: 'sd 4/29/2003 12:24'! filterToUnsentMessages "Filter the receiver's list down to only those items which have no senders" self filterFrom: [:aClass :aSelector | (self systemNavigation allCallsOn: aSelector) isEmpty]! ! !MessageSet methodsFor: 'message category functions' stamp: 'sw 10/8/2001 14:10'! canShowMultipleMessageCategories "Answer whether the receiver is capable of showing multiple message categories" ^ false! ! !MessageSet methodsFor: 'metaclass' stamp: 'nk 4/29/2004 12:20'! classCommentIndicated "Answer true iff we're viewing the class comment." ^ editSelection == #editComment or: [ self selectedMessageName == #Comment ]! ! !MessageSet methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 07:32'! dragPassengerFor: item inMorph: dragSource | transferType | transferType _ self dragTransferTypeForMorph: dragSource. transferType == #messageList ifTrue: [^self selectedClassOrMetaClass->(item contents findTokens: ' ') second asSymbol]. transferType == #classList ifTrue: [^self selectedClass]. ^nil! ! !MessageSet class methodsFor: 'utilities' stamp: 'RAA 5/29/2001 10:19'! extantMethodsIn: aListOfMethodRefs "Answer the subset of the incoming list consisting only of those message markers that refer to methods actually in the current image" self flag: #mref. "may be removed in second round" ^ aListOfMethodRefs select: [:aToken | self parse: aToken toClassAndSelector: [ :aClass :aSelector | aClass notNil and: [aClass includesSelector: aSelector] ] ]! ! !MessageSet class methodsFor: 'utilities' stamp: 'sw 6/6/2001 15:09'! isPseudoSelector: aSelector "Answer whether the given selector is a special marker" ^ #(Comment Definition Hierarchy) includes: aSelector! ! !MessageSet class methodsFor: 'utilities' stamp: 'bkv 4/2/2003 11:33'! parse: methodRef toClassAndSelector: csBlock "Decode strings of the form <className> [class] <selectorName>." | tuple cl | self flag: #mref. "compatibility with pre-MethodReference lists" methodRef ifNil: [^ csBlock value: nil value: nil]. (methodRef isKindOf: MethodReference) ifTrue: [ ^methodRef setClassAndSelectorIn: csBlock ]. methodRef isEmpty ifTrue: [^ csBlock value: nil value: nil]. tuple _ methodRef asString findTokens: ' .'. cl _ Smalltalk atOrBelow: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. (tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol] ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! ! !MessageSet class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:37'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Message List' brightColor: #lightBlue pastelColor: #paleBlue helpMessage: 'A list of messages (e.g. senders, implementors)'! ! !MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:05'! = aMessageTally self species == aMessageTally species ifFalse: [^ false]. ^ aMessageTally method == method! ! !MessageTally methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:04'! species ^MessageTally! ! !MessageTally methodsFor: 'initialize-release' stamp: 'nk 3/8/2004 12:29'! initialize maxClassNameSize _ self class defaultMaxClassNameSize. maxClassPlusSelectorSize _ self class defaultMaxClassPlusSelectorSize. maxTabs _ self class defaultMaxTabs.! ! !MessageTally methodsFor: 'initialize-release' stamp: 'bkv 1/25/2004 21:27'! spyEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." | myDelay startTime time0 | (aBlock isMemberOf: BlockContext) ifFalse: [self error: 'spy needs a block here']. self class: aBlock receiver class method: aBlock method. "set up the probe" ObservedProcess _ Processor activeProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. gcStats _ SmalltalkImage current getVMParameters. Timer := [[true] whileTrue: [startTime := Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor userInterruptPriority. "activate the probe and evaluate the block" Timer resume. ^ aBlock ensure: ["Collect gc statistics" SmalltalkImage current getVMParameters keysAndValuesDo: [:idx :gcVal| gcStats at: idx put: (gcVal - (gcStats at: idx))]. "cancel the probe and return the value" Timer terminate. time := Time millisecondClockValue - time0]! ! !MessageTally methodsFor: 'initialize-release' stamp: 'sd 9/30/2003 13:42'! spyEvery: millisecs onProcess: aProcess forMilliseconds: msecDuration "Create a spy and spy on the given process at the specified rate." | myDelay time0 endTime sem | (aProcess isKindOf: Process) ifFalse: [self error: 'spy needs a Process here']. self class: aProcess suspendedContext receiver class method: aProcess suspendedContext method. "set up the probe" ObservedProcess _ aProcess. myDelay _ Delay forMilliseconds: millisecs. time0 _ Time millisecondClockValue. endTime _ time0 + msecDuration. sem _ Semaphore new. gcStats _ SmalltalkImage current getVMParameters. Timer _ [[| startTime | startTime _ Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext by: Time millisecondClockValue - startTime // millisecs. startTime < endTime] whileTrue. sem signal] forkAt: (ObservedProcess priority + 1 min: Processor highestPriority). "activate the probe and wait for it to finish" sem wait. "Collect gc statistics" SmalltalkImage current getVMParameters keysAndValuesDo: [:idx :gcVal| gcStats at: idx put: (gcVal - gcStats at: idx)]. time _ Time millisecondClockValue - time0! ! !MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:14'! printOn: aStream | aSelector className aClass | (class isNil or: [method isNil]) ifTrue: [^super printOn: aStream]. aSelector := class selectorAtMethod: method setClass: [:c | aClass := c]. className := aClass name contractTo: self maxClassNameSize. aStream nextPutAll: className; nextPutAll: ' >> '; nextPutAll: (aSelector contractTo: self maxClassPlusSelectorSize - className size)! ! !MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:15'! printOn: aStream total: total totalTime: totalTime tallyExact: isExact | aSelector className myTally aClass percentage | isExact ifTrue: [myTally := tally. receivers == nil ifFalse: [receivers do: [:r | myTally := myTally - r tally]]. aStream print: myTally; space] ifFalse: [percentage := tally asFloat / total * 100.0 roundTo: 0.1. aStream print: percentage; nextPutAll: '% {'; print: (percentage * totalTime / 100) rounded; nextPutAll: 'ms} ']. receivers == nil ifTrue: [aStream nextPutAll: 'primitives'; cr] ifFalse: [aSelector := class selectorAtMethod: method setClass: [:c | aClass := c]. className := aClass name contractTo: self maxClassNameSize. aStream nextPutAll: class name; nextPutAll: (aClass = class ifTrue: ['>>'] ifFalse: ['(' , aClass name , ')>>']); nextPutAll: (aSelector contractTo: self maxClassPlusSelectorSize - className size); cr]! ! !MessageTally methodsFor: 'printing' stamp: 'nk 3/8/2004 12:23'! treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold | sons sonTab | tabs do: [:tab | aStream nextPutAll: tab]. tabs size > 0 ifTrue: [self printOn: aStream total: total totalTime: totalTime tallyExact: isExact]. sons := isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold]. sons isEmpty ifFalse: [tabs addLast: myTab. sons := sons asSortedCollection. (1 to: sons size) do: [:i | sonTab := i < sons size ifTrue: [' |'] ifFalse: [' ']. (sons at: i) treePrintOn: aStream tabs: (tabs size < self maxTabs ifTrue: [tabs] ifFalse: [(tabs select: [:x | x = '[']) copyWith: '[']) thisTab: sonTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold]. tabs removeLast]! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxClassNameSize ^maxClassNameSize! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassNameSize: aNumber maxClassNameSize := aNumber! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxClassPlusSelectorSize ^maxClassPlusSelectorSize! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassPlusSelectorSize: aNumber maxClassPlusSelectorSize := aNumber! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxTabs ^maxTabs! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxTabs: aNumber maxTabs := aNumber! ! !MessageTally methodsFor: 'reporting' stamp: 'spfa 6/1/2004 19:23'! report: strm cutoff: threshold tally = 0 ifTrue: [strm nextPutAll: ' - no tallies obtained'] ifFalse: [strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr. self fullPrintOn: strm tallyExact: false orThreshold: threshold]. time isZero ifFalse: [self reportGCStatsOn: strm].! ! !MessageTally methodsFor: 'reporting' stamp: 'ar 7/18/2001 22:12'! reportGCStatsOn: str | oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime rootOverflows | upTime _ time. oldSpaceEnd _ gcStats at: 1. youngSpaceEnd _ gcStats at: 2. memoryEnd _ gcStats at: 3. fullGCs _ gcStats at: 7. fullGCTime _ gcStats at: 8. incrGCs _ gcStats at: 9. incrGCTime _ gcStats at: 10. tenureCount _ gcStats at: 11. rootOverflows _ gcStats at: 22. str cr. str nextPutAll: '**Memory**'; cr. str nextPutAll: ' old '; nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' young '; nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' used '; nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str nextPutAll: ' free '; nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr. str cr. str nextPutAll: '**GCs**'; cr. str nextPutAll: ' full '; print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((fullGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. fullGCs = 0 ifFalse: [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' incr '; print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((incrGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. incrGCs = 0 ifFalse: [str nextPutAll:', avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' tenures '; nextPutAll: tenureCount asStringWithCommas. tenureCount = 0 ifFalse: [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. str cr. str nextPutAll: ' root table '; nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'. str cr. ! ! !MessageTally commentStamp: 'nk 3/8/2004 12:43' prior: 0! My instances observe and report the amount of time spent in methods. NOTE: a higher-level user interface (combining the MessageTally result tree with a method browser) is available from TimeProfileBrowser. MessageTally provides two different strategies available for profiling: * spyOn: and friends use a high-priority Process to interrupt the block or process being spied on at periodic intervals. The interrupted call stack is then examined for caller information. * tallySends: and friends use the interpreter simulator to run the block, recording every method call. The two give you different results: * spyOn: gives you a view of where the time is being spent in your program, at least on a rough statistical level (assuming you've run the block for long enough and have a high enough poll rate). If you're trying to optimize your code, start here and optimize the methods where most of the time is being spent first. * tallySends: gives you accurate counts of how many times methods get called, and by exactly which route. If you're debugging, or trying to figure out if a given method is getting called too many times, this is your tool. You can change the printing format (that is, the whitespace and string compression) by using these instance methods: maxClassNameSize: maxClassPlusSelectorSize: maxTabs: You can change the default polling period (initially set to 1) by calling MessageTally defaultPollPeriod: numberOfMilliseconds Q: How do you interpret MessageTally>>tallySends A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format. #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.! !MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:34'! spyOn: aBlock "MessageTally spyOn: [100 timesRepeat: [3.14159 printString]]" | node result | node _ self new. result _ node spyEvery: self defaultPollPeriod on: aBlock. (StringHolder new contents: (String streamContents: [:s | node report: s; close])) openLabel: 'Spy Results'. ^ result! ! !MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:34'! spyOn: aBlock toFileNamed: fileName "Spy on the evaluation of aBlock. Write the data collected on a file named fileName." | file value node | node _ self new. value _ node spyEvery: self defaultPollPeriod on: aBlock. file _ FileStream newFileNamed: fileName. node report: file; close. file close. ^value! ! !MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:35'! spyOnProcess: aProcess forMilliseconds: msecDuration "| p | p _ [100000 timesRepeat: [3.14159 printString]] fork. (Delay forMilliseconds: 100) wait. MessageTally spyOnProcess: p forMilliseconds: 1000" | node | node _ self new. node spyEvery: self defaultPollPeriod onProcess: aProcess forMilliseconds: msecDuration. (StringHolder new contents: (String streamContents: [:s | node report: s; close])) openLabel: 'Spy Results'! ! !MessageTally class methodsFor: 'spying' stamp: 'nk 3/8/2004 10:35'! spyOnProcess: aProcess forMilliseconds: msecDuration toFileNamed: fileName "Spy on the evaluation of aProcess. Write the data collected on a file named fileName. Will overwrite fileName" | file node | node _ self new. node spyEvery: self defaultPollPeriod onProcess: aProcess forMilliseconds: msecDuration. file _ FileStream fileNamed: fileName. node report: file; close. file close! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'! defaultMaxClassNameSize "Return the default maximum width of the class name alone" ^30! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:27'! defaultMaxClassPlusSelectorSize "Return the default maximum width of the class plus selector together (not counting the '>>')" ^60! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:26'! defaultMaxTabs "Return the default number of tabs after which leading white space is compressed" ^18! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! defaultPollPeriod "Answer the number of milliseconds between interrupts for spyOn: and friends. This should be faster for faster machines." ^DefaultPollPeriod ifNil: [ DefaultPollPeriod _ 1 ]! ! !MessageTally class methodsFor: 'defaults' stamp: 'nk 3/8/2004 12:41'! defaultPollPeriod: numberOfMilliseconds "Set the default number of milliseconds between interrupts for spyOn: and friends. This should be faster for faster machines." DefaultPollPeriod := numberOfMilliseconds! ! !Metaclass methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:51'! theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self! ! !Metaclass methodsFor: 'instance creation' stamp: 'nk 11/9/2003 10:00'! new "The receiver can only have one instance. Create it or complain that one already exists." thisClass class ~~ self ifTrue: [^thisClass _ self basicNew] ifFalse: [self error: 'A Metaclass should only have one instance!!']! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! addObsoleteSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! obsoleteSubclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass obsoleteSubclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! removeObsoleteSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'compiling' stamp: 'ar 5/18/2003 18:13'! bindingOf: varName ^thisClass classBindingOf: varName! ! !Metaclass methodsFor: 'private' stamp: 'ar 3/3/2001 00:20'! replaceObsoleteInstanceWith: newInstance thisClass class == self ifTrue:[^self error:'I am fine, thanks']. newInstance class == self ifFalse:[^self error:'Not an instance of me']. thisClass _ newInstance.! ! !MethodCall methodsFor: 'initialization' stamp: 'sw 11/20/2001 13:34'! receiver: aReceiver methodInterface: aMethodInterface "Initialize me to have the given receiver and methodInterface" | aResultType | receiver _ aReceiver. selector _ aMethodInterface selector. methodInterface _ aMethodInterface. arguments _ aMethodInterface defaultArguments. self flag: #noteToTed. "the below can't really survive, I know. The intent is that if the method has a declared result type, we want the preferred readout type to be able to handle the initial #lastValue even if the MethodCall has not been evaluated yet; thus we'd rather have a boolean value such as true rather than a nil here if we're showing a boolean readout such as a checkbox, and likewise for color-valued and numeric-valued readouts etc, " (aResultType _ methodInterface resultType) ~~ #unknown ifTrue: [lastValue _ (Vocabulary vocabularyForType: aResultType) initialValueForASlotFor: aReceiver] ! ! !MethodCall methodsFor: 'initialization' stamp: 'sw 10/3/2001 15:28'! receiver: aReceiver methodInterface: aMethodInterface initialArguments: initialArguments "Set up a method-call for the given receiver, method-interface, and initial arguments" receiver _ aReceiver. selector _ aMethodInterface selector. methodInterface _ aMethodInterface. arguments _ initialArguments ifNotNil: [initialArguments asArray] ! ! !MethodCall methodsFor: 'initialization' stamp: 'sw 11/20/2001 12:16'! valueOfArgumentNamed: aName "Answer the value of the given arguement variable" | anIndex | anIndex _ self methodInterface argumentVariables findFirst: [:aVariable | aVariable variableName = aName]. ^ anIndex > 0 ifTrue: [arguments at: anIndex] ifFalse: [self error: 'variable not found']! ! !MethodCall methodsFor: 'argument access' stamp: 'sw 11/20/2001 12:16'! setArgumentNamed: aName toValue: aValue "Set the argument of the given name to the given value" | anIndex | anIndex _ self methodInterface argumentVariables findFirst: [:aVariable | aVariable variableName = aName]. anIndex > 0 ifTrue: [arguments at: anIndex put: aValue] ifFalse: [self error: 'argument missing']. self changed: #argumentValue! ! !MethodCall methodsFor: 'evaluation' stamp: 'sw 11/20/2001 12:15'! evaluate "Evaluate the receiver, and if value has changed, signal value-changed" | result | result _ arguments isEmptyOrNil ifTrue: [self receiver perform: selector] ifFalse: [self receiver perform: selector withArguments: arguments asArray]. timeStamp _ Time dateAndTimeNow. result ~= lastValue ifTrue: [lastValue _ result. self changed: #value] ! ! !MethodCall methodsFor: 'evaluation' stamp: 'sw 11/20/2001 12:21'! everEvaluated "Answer whether this method call has ever been evaluated" ^ timeStamp notNil! ! !MethodCall methodsFor: 'evaluation' stamp: 'sw 11/20/2001 13:31'! lastValue "Answer the last value I remember obtaining from an evaluation" ^ lastValue! ! !MethodCall methodsFor: 'method interface'! ephemeralMethodInterface "Answer a methodInterface for me. If I have one stored, answer it; if not, conjure up an interface and answer it but do NOT store it internally. You can call this directly if you need a method interface for me but do not want any conjured-up interface to persist." ^ methodInterface ifNil: [MethodInterface new conjuredUpFor: selector class: (self receiver class whichClassIncludesSelector: selector)]! ! !MethodCall methodsFor: 'method interface' stamp: 'sw 11/20/2001 12:43'! methodInterface "Answer the receiver's methodInterface, conjuring one up on the spot (and remembering) if not present" ^ methodInterface ifNil: [methodInterface _ self ephemeralMethodInterface]! ! !MethodCall methodsFor: 'method interface' stamp: 'sw 11/20/2001 12:39'! methodInterface: anInterface "Set my methodInterface" methodInterface _ anInterface! ! !MethodCall methodsFor: 'method interface' stamp: 'sw 11/20/2001 12:40'! methodInterfaceOrNil "Answer my methodInterface, whether it is nil or not" ^ methodInterface! ! !MethodCall commentStamp: '<historical>' prior: 0! A MethodCall is a resendable message-send, complete with receiver, instantiated arguments, and a memory of when it was last evaluated and what the last value was. The methodInterface with which it is associated can furnish argument names, documentation, and other information.! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'ar 5/23/2001 16:16'! storeDataOn: aDataStream | oldMethod | oldMethod _ currentMethod. currentMethod _ nil. super storeDataOn: aDataStream. currentMethod _ oldMethod. ! ! !MethodContext methodsFor: 'initialize-release' stamp: 'ajh 1/23/2003 20:27'! privRefresh "Reinitialize the receiver so that it is in the state it was at its creation." pc _ method initialPC. self stackp: method numTemps. method numArgs+1 to: method numTemps do: [:i | self tempAt: i put: nil]! ! !MethodContext methodsFor: 'initialize-release' stamp: 'ajh 5/22/2003 16:28'! privRefreshWith: aCompiledMethod "Reinitialize the receiver as though it had been for a different method. Used by a Debugger when one of the methods to which it refers is recompiled." method _ aCompiledMethod. receiverMap _ nil. self privRefresh! ! !MethodContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 16:55'! blockHome "If executing closure, search senders for method containing my closure method. If not found return nil." | m | self isExecutingBlock ifFalse: [^ self]. self sender ifNil: [^ nil]. m _ self method. ^ self sender findContextSuchThat: [:c | c method hasLiteralThorough: m]! ! !MethodContext methodsFor: 'accessing' stamp: 'ajh 1/31/2003 23:29'! finalBlockHome "If executing closure, search senders for original method containing my closure method. If not found return nil." | h | self isExecutingBlock ifFalse: [^ self]. ^ (h _ self blockHome) ifNotNil: [h finalBlockHome]! ! !MethodContext methodsFor: 'accessing' stamp: 'ar 6/28/2003 00:04'! isExecutingBlock "Is this executing a block versus a method" | r | Smalltalk at: #BlockClosure ifPresent:[:aClass| ^((r _ self receiver) isKindOf: aClass) and: [r method == self method] ]. ^false! ! !MethodContext methodsFor: 'accessing' stamp: 'ajh 9/28/2001 02:16'! isMethodContext ^ true! ! !MethodContext methodsFor: 'accessing' stamp: 'ajh 2/9/2003 00:08'! methodNode | h | ^ self isExecutingBlock ifTrue: [self method blockNodeIn: ((h _ self blockHome) ifNotNil: [h methodNode])] ifFalse: [super methodNode]! ! !MethodContext methodsFor: 'private' stamp: 'ajh 8/13/2002 13:34'! startpc ^ self method initialPC! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'hg 10/2/2001 20:43'! cannotReturn: result Debugger openContext: thisContext label: 'computation has been terminated' contents: nil! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! isHandlerContext "is this context for method that is marked?" ^method primitive = 199! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! isUnwindContext "is this context for method that is marked?" ^method primitive = 198! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'ar 6/28/2003 00:10'! restartWithNewReceiver: obj self swapReceiver: obj; restart! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'ajh 10/8/2001 23:56'! swapReceiver: r receiver := r! ! !MethodContext methodsFor: 'controlling' stamp: 'ar 3/6/2001 15:02'! answer: anObject "ar 3/6/2001: OBSOLETE. Must not be used. Will be removed VERY SOON." "Modify my code, from the current program counter value, to answer anObject." self push: anObject. (method at: pc) = 124 ifFalse: [ method _ ( (method clone) at: pc + 1 put: 124; yourself)]! ! !MethodContext methodsFor: 'private-debugger' stamp: 'ajh 1/24/2003 23:38'! cachesStack ^ false "^self selector == #valueUninterruptably and: [self receiver class == BlockContext]"! ! !MethodContext methodsFor: 'printing' stamp: 'tk 10/19/2001 11:34'! printDetails: strm "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." | pe str pos | self printOn: strm. strm cr. strm tab; nextPutAll: 'Receiver: '. pe _ '<<error during printing>>'. strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe]). strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str _ [(self tempsAndValuesLimitedTo: 80 indent: 2) padded: #right to: 1 with: $x] ifError: [:err :rcvr | pe]. strm nextPutAll: (str allButLast). strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. pos _ strm position. [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [:err :rcvr | strm nextPutAll: pe]. pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [:err :rcvr | pe])]. strm peekLast == Character cr ifFalse: [strm cr].! ! !MethodContext methodsFor: 'printing' stamp: 'ajh 1/31/2003 20:34'! printOn: aStream | h | self isExecutingBlock ifFalse: [^ super printOn: aStream]. h _ self blockHome. h ifNil: [^ aStream nextPutAll: '[]']. aStream nextPutAll: '[] from '. h printOn: aStream! ! !MethodContext methodsFor: 'printing' stamp: 'emm 5/30/2002 14:07'! printString "Answer an emphasized string in case of a breakpoint method" ^self method hasBreakpoint ifTrue:[(super printString , ' [break]') asText allBold] ifFalse:[super printString]! ! !MethodContext methodsFor: 'printing' stamp: 'LC 1/6/2002 11:13'! who | sel mcls | self method ifNil: [^ Array with: #unknown with: #unknown]. sel _ self receiver class selectorAtMethod: self method setClass: [:c | mcls _ c]. sel == #? ifTrue: [^ self method who]. ^ Array with: mcls with: sel ! ! !MethodContext methodsFor: 'closure support' stamp: 'ar 6/28/2003 00:15'! contextTag "Context tags may be used for referring to contexts instead of contexts themselves as they can be copied and will continue to work in other processes (continuations). By default, we use the context itself to as its tag." ^self! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/30/2004 13:35'! testActivateReturnValue self assert: ((aSender activateReturn: aMethodContext value: #()) isKindOf: MethodContext). self assert: ((aSender activateReturn: aMethodContext value: #()) receiver = aMethodContext).! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 17:09'! testCopyStack self assert: aMethodContext copyStack printString = aMethodContext printString.! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 17:10'! testFindContextSuchThat self assert: (aMethodContext findContextSuchThat: [:each| true]) printString = aMethodContext printString. self assert: (aMethodContext hasContext: aMethodContext). ! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/30/2004 10:57'! testMethodContext self deny: aMethodContext isPseudoContext. self assert: aMethodContext home notNil. self assert: aMethodContext receiver notNil. self assert: (aMethodContext method isKindOf: CompiledMethod).! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 17:08'! testMethodIsBottomContext self assert: aMethodContext bottomContext = aSender. self assert: aMethodContext secondFromBottom = aMethodContext.! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 16:55'! testReturn "Why am I overriding setUp? Because sender must be thisContext, i.e, testReturn, not setUp." aMethodContext _ MethodContext sender: thisContext receiver: aReceiver method: aCompiledMethod arguments: #(). self assert: (aMethodContext return: 5) = 5.! ! !MethodContextTest methodsFor: 'testing' stamp: 'tlk 5/31/2004 16:52'! testSetUp "Note: In addition to verifying that the setUp worked the way it was expected to, testSetUp is used to illustrate the meaning of the simple access methods, methods that are not normally otherwise 'tested'" self assert: aMethodContext isMethodContext. self deny: aMethodContext isBlockClosure. self deny: aMethodContext isPseudoContext. self deny: aMethodContext isDead. "self assert: aMethodContext home = aReceiver." "self assert: aMethodContext blockHome = aReceiver." self assert: aMethodContext receiver = aReceiver. self assert: (aMethodContext method isKindOf: CompiledMethod). self assert: aMethodContext method = aCompiledMethod. self assert: aMethodContext methodNode selector = #rightCenter. self assert: (aMethodContext methodNodeFormattedAndDecorated: true) selector = #rightCenter. self assert: aMethodContext client printString = 'MethodContextTest>>#testSetUp'. ! ! !MethodContextTest methodsFor: 'Running' stamp: 'tlk 5/31/2004 16:18'! setUp super setUp. aCompiledMethod _ Rectangle methodDict at: #rightCenter. aReceiver _ 100@100 corner: 200@200. aSender _ thisContext. aMethodContext _ MethodContext sender: aSender receiver: aReceiver method: aCompiledMethod arguments: #(). ! ! !MethodContextTest commentStamp: 'tlk 5/31/2004 16:07' prior: 0! I am an SUnit Test of MethodContext and its super type, ContextPart. See also BlockContextTest. See pages 430-437 of A. Goldberg and D. Robson's Smalltalk-80 The Language (aka the purple book), which deal with Contexts. My fixtures are from their example. (The Squeak byte codes are not quite the same as Smalltalk-80.) My fixtures are: aReceiver - just some arbitrary object, "Rectangle origin: 100@100 corner: 200@200" aSender - just some arbitrary object, thisContext aCompiledMethod - just some arbitrary method, "Rectangle rightCenter". aMethodContext - just some arbitray context ... ! !MethodDictionary methodsFor: 'accessing' stamp: 'raa 5/30/2001 15:04'! at: key putNoBecome: value "Set the value at key to be value. Answer the resulting MethodDictionary" | index | index _ self findElementOrNil: key. (self basicAt: index) == nil ifTrue: [tally _ tally + 1. self basicAt: index put: key] ifFalse: [(array at: index) flushCache]. array at: index put: value. ^self fullCheckNoBecome! ! !MethodDictionary methodsFor: 'removing' stamp: 'raa 5/30/2001 15:19'! removeKeyNoBecome: key "The interpreter might be using this MethodDict while this method is running!! Therefore we perform the removal in a copy, and then return the copy for subsequent installation" | copy | copy _ self copy. copy removeDangerouslyKey: key ifAbsent: [^ self]. ^copy! ! !MethodDictionary methodsFor: 'private' stamp: 'raa 5/30/2001 15:03'! fullCheckNoBecome "Keep array at least 1/4 free for decent hash behavior" array size - tally < (array size // 4 max: 1) ifTrue: [^self growNoBecome]. ^self ! ! !MethodDictionary methodsFor: 'private' stamp: 'raa 5/30/2001 15:02'! growNoBecome | newSelf key | newSelf _ self species new: self basicSize. "This will double the size" 1 to: self basicSize do: [:i | key _ self basicAt: i. key == nil ifFalse: [newSelf at: key put: (array at: i)]]. ^newSelf! ! !MethodDictionary class methodsFor: 'instance creation' stamp: 'RAA 5/29/2001 09:53'! new "change the default size to be a bit bigger to help reduce the number of #grows while filing in" ^self new: 16! ! !MethodFinder methodsFor: 'initialize' stamp: 'md 11/14/2003 16:47'! copy: mthFinder addArg: aConstant | more | "Copy inputs and answers, add an additional data argument to the inputs. The same constant for every example" more _ Array with: aConstant. data _ mthFinder data collect: [:argList | argList, more]. answers _ mthFinder answers. self load: nil. ! ! !MethodFinder methodsFor: 'initialize' stamp: 'md 10/6/2004 15:54'! initialize "The methods we are allowed to use. (MethodFinder new initialize) " Approved _ Set new. AddAndRemove _ Set new. Blocks _ Set new. "These modify an argument and are not used by the MethodFinder: longPrintOn: printOn: storeOn: sentTo: storeOn:base: printOn:base: absPrintExactlyOn:base: absPrintOn:base: absPrintOn:base:digitCount: writeOn: writeScanOn: possibleVariablesFor:continuedFrom: printOn:format:" "Object" #("in class, instance creation" categoryForUniclasses chooseUniqueClassName initialInstance isSystemDefined newFrom: officialClass readCarefullyFrom: "accessing" at: basicAt: basicSize bindWithTemp: in: size yourself "testing" basicType ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isColor isFloat isFraction isInMemory isInteger isMorph isNil isNumber isPoint isPseudoContext isText isTransparent isWebBrowser knownName notNil pointsTo: wantsSteps "comparing" = == closeTo: hash hashMappedBy: identityHash identityHashMappedBy: identityHashPrintString ~= ~~ "copying" clone copy shallowCopy "dependents access" canDiscardEdits dependents hasUnacceptedEdits "updating" changed changed: okToChange update: windowIsClosing "printing" fullPrintString isLiteral longPrintString printString storeString stringForReadout stringRepresentation "class membership" class isKindOf: isKindOf:orOf: isMemberOf: respondsTo: xxxClass "error handling" "user interface" addModelMenuItemsTo:forMorph:hand: defaultBackgroundColor defaultLabelForInspector fullScreenSize initialExtent modelWakeUp mouseUpBalk: newTileMorphRepresentative windowActiveOnFirstClick windowReqNewLabel: "system primitives" asOop instVarAt: instVarNamed: "private" "associating" -> "converting" as: asOrderedCollection asString "casing" caseOf: caseOf:otherwise: "binding" bindingOf: "macpal" contentsChanged currentEvent currentHand currentWorld flash ifKindOf:thenDo: instanceVariableValues scriptPerformer "flagging" flag: "translation support" "objects from disk" "finalization" ) do: [:sel | Approved add: sel]. #(at:add: at:modify: at:put: basicAt:put: "NOT instVar:at:" "message handling" perform: perform:orSendTo: perform:with: perform:with:with: perform:with:with:with: perform:withArguments: perform:withArguments:inSuperclass: ) do: [:sel | AddAndRemove add: sel]. "Boolean, True, False, UndefinedObject" #("logical operations" & eqv: not xor: | "controlling" and: ifFalse: ifFalse:ifTrue: ifTrue: ifTrue:ifFalse: or: "copying" "testing" isEmptyOrNil) do: [:sel | Approved add: sel]. "Behavior" #("initialize-release" "accessing" compilerClass decompilerClass evaluatorClass format methodDict parserClass sourceCodeTemplate subclassDefinerClass "testing" instSize instSpec isBits isBytes isFixed isPointers isVariable isWeak isWords "copying" "printing" defaultNameStemForInstances printHierarchy "creating class hierarchy" "creating method dictionary" "instance creation" basicNew basicNew: new new: "accessing class hierarchy" allSubclasses allSubclassesWithLevelDo:startingLevel: allSuperclasses subclasses superclass withAllSubclasses withAllSuperclasses "accessing method dictionary" allSelectors changeRecordsAt: compiledMethodAt: compiledMethodAt:ifAbsent: firstCommentAt: lookupSelector: selectors selectorsDo: selectorsWithArgs: "slow but useful ->" sourceCodeAt: sourceCodeAt:ifAbsent: sourceMethodAt: sourceMethodAt:ifAbsent: "accessing instances and variables" allClassVarNames allInstVarNames allSharedPools classVarNames instVarNames instanceCount sharedPools someInstance subclassInstVarNames "testing class hierarchy" inheritsFrom: kindOfSubclass "testing method dictionary" canUnderstand: classThatUnderstands: hasMethods includesSelector: scopeHas:ifTrue: whichClassIncludesSelector: whichSelectorsAccess: whichSelectorsReferTo: whichSelectorsReferTo:special:byte: whichSelectorsStoreInto: "enumerating" "user interface" "private" indexIfCompact) do: [:sel | Approved add: sel]. "ClassDescription" #("initialize-release" "accessing" classVersion isMeta name theNonMetaClass "copying" "printing" classVariablesString instanceVariablesString sharedPoolsString "instance variables" checkForInstVarsOK: "method dictionary" "organization" category organization whichCategoryIncludesSelector: "compiling" acceptsLoggingOfCompilation wantsChangeSetLogging "fileIn/Out" definition "private" ) do: [:sel | Approved add: sel]. "Class" #("initialize-release" "accessing" classPool "testing" "copying" "class name" "instance variables" "class variables" classVarAt: classVariableAssociationAt: "pool variables" "compiling" "subclass creation" "fileIn/Out" ) do: [:sel | Approved add: sel]. "Metaclass" #("initialize-release" "accessing" isSystemDefined soleInstance "copying" "instance creation" "instance variables" "pool variables" "class hierarchy" "compiling" "fileIn/Out" nonTrivial ) do: [:sel | Approved add: sel]. "Context, BlockContext" #(receiver client method receiver tempAt: "debugger access" mclass pc selector sender shortStack sourceCode tempNames tempsAndValues "controlling" "printing" "system simulation" "initialize-release" "accessing" hasMethodReturn home numArgs "evaluating" value value:ifError: value:value: value:value:value: value:value:value:value: valueWithArguments: "controlling" "scheduling" "instruction decoding" "printing" "private" "system simulation" ) do: [:sel | Approved add: sel]. #(value: "<- Association has it as a store" ) do: [:sel | AddAndRemove add: sel]. "Message" #("inclass, instance creation" selector: selector:argument: selector:arguments: "accessing" argument argument: arguments sends: "printing" "sending" ) do: [:sel | Approved add: sel]. #("private" setSelector:arguments:) do: [:sel | AddAndRemove add: sel]. "Magnitude" #("comparing" < <= > >= between:and: "testing" max: min: min:max: ) do: [:sel | Approved add: sel]. "Date, Time" #("in class, instance creation" fromDays: fromSeconds: fromString: newDay:month:year: newDay:year: today "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: nameOfDay: nameOfMonth: "accessing" day leap monthIndex monthName weekday year "arithmetic" addDays: subtractDate: subtractDays: "comparing" "inquiries" dayOfMonth daysInMonth daysInYear daysLeftInYear firstDayOfMonth previous: "converting" asSeconds "printing" mmddyy mmddyyyy printFormat: "private" firstDayOfMonthIndex: weekdayIndex "in class, instance creation" fromSeconds: now "in class, general inquiries" dateAndTimeFromSeconds: dateAndTimeNow millisecondClockValue millisecondsToRun: totalSeconds "accessing" hours minutes seconds "arithmetic" addTime: subtractTime: "comparing" "printing" intervalString print24 "converting") do: [:sel | Approved add: sel]. #("private" hours: hours:minutes:seconds: day:year: ) do: [:sel | AddAndRemove add: sel]. "Number" #("in class" readFrom:base: "arithmetic" * + - / // \\ abs negated quo: reciprocal rem: "mathematical functions" arcCos arcSin arcTan arcTan: cos exp floorLog: ln log log: raisedTo: raisedToInteger: sin sqrt squared tan "truncation and round off" ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated "comparing" "testing" even isDivisibleBy: isInf isInfinite isNaN isZero negative odd positive sign strictlyPositive "converting" @ asInteger asNumber asPoint asSmallAngleDegrees degreesToRadians radiansToDegrees "intervals" to: to:by: "printing" printStringBase: storeStringBase: ) do: [:sel | Approved add: sel]. "Integer" #("in class" primesUpTo: "testing" isPowerOfTwo "arithmetic" alignedTo: "comparing" "truncation and round off" atRandom normalize "enumerating" timesRepeat: "mathematical functions" degreeCos degreeSin factorial gcd: lcm: take: "bit manipulation" << >> allMask: anyMask: bitAnd: bitClear: bitInvert bitInvert32 bitOr: bitShift: bitXor: lowBit noMask: "converting" asCharacter asColorOfDepth: asFloat asFraction asHexDigit "printing" asStringWithCommas hex hex8 radix: "system primitives" lastDigit replaceFrom:to:with:startingAt: "private" "benchmarks" ) do: [:sel | Approved add: sel]. "SmallInteger, LargeNegativeInteger, LargePositiveInteger" #("arithmetic" "bit manipulation" highBit "testing" "comparing" "copying" "converting" "printing" "system primitives" digitAt: digitLength "private" fromString:radix: ) do: [:sel | Approved add: sel]. #(digitAt:put: ) do: [:sel | AddAndRemove add: sel]. "Float" #("arithmetic" "mathematical functions" reciprocalFloorLog: reciprocalLogBase2 timesTwoPower: "comparing" "testing" "truncation and round off" exponent fractionPart integerPart significand significandAsInteger "converting" asApproximateFraction asIEEE32BitWord asTrueFraction "copying") do: [:sel | Approved add: sel]. "Fraction, Random" #(denominator numerator reduced next nextValue) do: [:sel | Approved add: sel]. #(setNumerator:denominator:) do: [:sel | AddAndRemove add: sel]. "Collection" #("accessing" anyOne "testing" includes: includesAllOf: includesAnyOf: includesSubstringAnywhere: isEmpty isSequenceable occurrencesOf: "enumerating" collect: collect:thenSelect: count: detect: detect:ifNone: detectMax: detectMin: detectSum: inject:into: reject: select: select:thenCollect: intersection: "converting" asBag asCharacterSet asSet asSortedArray asSortedCollection asSortedCollection: "printing" "private" maxSize "arithmetic" "math functions" average max median min range sum) do: [:sel | Approved add: sel]. #("adding" add: addAll: addIfNotPresent: "removing" remove: remove:ifAbsent: removeAll: removeAllFoundIn: removeAllSuchThat: remove:ifAbsent:) do: [:sel | AddAndRemove add: sel]. "SequenceableCollection" #("comparing" hasEqualElements: "accessing" allButFirst allButLast at:ifAbsent: atAll: atPin: atRandom: atWrap: fifth first fourth identityIndexOf: identityIndexOf:ifAbsent: indexOf: indexOf:ifAbsent: indexOf:startingAt:ifAbsent: indexOfSubCollection:startingAt: indexOfSubCollection:startingAt:ifAbsent: last second sixth third "removing" "copying" , copyAfterLast: copyAt:put: copyFrom:to: copyReplaceAll:with: copyReplaceFrom:to:with: copyUpTo: copyUpToLast: copyWith: copyWithout: copyWithoutAll: forceTo:paddingWith: shuffled sortBy: "enumerating" collectWithIndex: findFirst: findLast: pairsCollect: with:collect: withIndexCollect: polynomialEval: "converting" asArray asDictionary asFloatArray asIntegerArray asStringWithCr asWordArray reversed "private" copyReplaceAll:with:asTokens: ) do: [:sel | Approved add: sel]. #( swap:with:) do: [:sel | AddAndRemove add: sel]. "ArrayedCollection, Bag" #("private" defaultElement "sorting" isSorted "accessing" cumulativeCounts sortedCounts sortedElements "testing" "adding" add:withOccurrences: "removing" "enumerating" ) do: [:sel | Approved add: sel]. #( mergeSortFrom:to:by: sort sort: add: add:withOccurrences: "private" setDictionary ) do: [:sel | AddAndRemove add: sel]. "Other messages that modify the receiver" #(atAll:put: atAll:putAll: atAllPut: atWrap:put: replaceAll:with: replaceFrom:to:with: removeFirst removeLast) do: [:sel | AddAndRemove add: sel]. self initialize2. " MethodFinder new initialize. MethodFinder new organizationFiltered: Set " ! ! !MethodFinder methodsFor: 'initialize' stamp: 'ads 3/29/2003 17:12'! initialize2 "The methods we are allowed to use. (MethodFinder new initialize) " "Set" #("in class" sizeFor: "testing" "adding" "removing" "enumerating" "private" array findElementOrNil: "accessing" someElement) do: [:sel | Approved add: sel]. "Dictionary, IdentityDictionary, IdentitySet" #("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys "testing" includesKey: ) do: [:sel | Approved add: sel]. #(removeKey: removeKey:ifAbsent: ) do: [:sel | AddAndRemove add: sel]. "LinkedList, Interval, MappedCollection" #("in class" from:to: from:to:by: "accessing" contents) do: [:sel | Approved add: sel]. #( "adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel]. "OrderedCollection, SortedCollection" #("accessing" after: before: "copying" copyEmpty "adding" growSize "removing" "enumerating" "private" "accessing" sortBlock) do: [:sel | Approved add: sel]. #("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast: "removing" removeAt: removeFirst removeLast "accessing" sortBlock:) do: [:sel | AddAndRemove add: sel]. "Character" #("in class, instance creation" allCharacters digitValue: new separators "accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab "constants" alphabet characterTable "accessing" asciiValue digitValue "comparing" "testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish "copying" "converting" asIRCLowercase asLowercase asUppercase ) do: [:sel | Approved add: sel]. "String" #("in class, instance creation" crlf fromPacked: "primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: "internet" valueOfHtmlEntity: "accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit "comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: "copying" copyReplaceTokens:with: padded:to:with: "converting" asByteArray asDate asDisplayText asFileName asHtml asLegalSelector asPacked asParagraph asText asTime asUnHtml asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks "displaying" "printing" "system primitives" compare:with:collated: "Celeste" withCRs "internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting "testing" isAllSeparators lastSpacePosition "paragraph support" indentationIfBlank: "arithmetic" ) do: [:sel | Approved add: sel]. #(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel]. "Symbol" #("in class, private" hasInterned:ifTrue: "access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping: "accessing" "comparing" "copying" "converting" "printing" "testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel]. "Array" #("comparing" "converting" evalStrings "printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel]. "Array2D" #("access" at:at: atCol: atCol:put: atRow: extent extent:fromArray: height width width:height:type:) do: [:sel | Approved add: sel]. #(at:at:add: at:at:put: atRow:put: ) do: [:sel | AddAndRemove add: sel]. "ByteArray" #("accessing" doubleWordAt: wordAt: "platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: "converting") do: [:sel | Approved add: sel]. #(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian: ) do: [:sel | AddAndRemove add: sel]. "FloatArray" "Dont know what happens when prims not here" false ifTrue: [#("accessing" "arithmetic" *= += -= /= "comparing" "primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar: "primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to: "converting" "private" "user interface") do: [:sel | Approved add: sel]. ]. "IntegerArray, WordArray" "RunArray" #("in class, instance creation" runs:values: scanFrom: "accessing" runLengthAt: "adding" "copying" "private" runs values) do: [:sel | Approved add: sel]. #(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty: ) do: [:sel | AddAndRemove add: sel]. "Stream -- many operations change its state" #("testing" atEnd) do: [:sel | Approved add: sel]. #("accessing" next: nextMatchAll: nextMatchFor: upToEnd next:put: nextPut: nextPutAll: "printing" print: printHtml: ) do: [:sel | AddAndRemove add: sel]. "PositionableStream" #("accessing" contentsOfEntireFile originalContents peek peekFor: "testing" "positioning" position ) do: [:sel | Approved add: sel]. #(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel]. "Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics. We want to find the messages that convert Streams to other things." "ReadWriteStream" #("file status" closed) do: [:sel | Approved add: sel]. #("accessing" next: on: ) do: [:sel | AddAndRemove add: sel]. "WriteStream" #("in class, instance creation" on:from:to: with: with:from:to: ) do: [:sel | Approved add: sel]. #("positioning" resetToStart "character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel]. "LookupKey, Association, Link" #("accessing" key nextLink) do: [:sel | Approved add: sel]. #(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel]. "Point" #("in class, instance creation" r:degrees: x:y: "accessing" x y "comparing" "arithmetic" "truncation and round off" "polar coordinates" degrees r theta "point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector "converting" asFloatPoint asIntegerPoint corner: extent: rect: "transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying" "interpolating" interpolateTo:at:) do: [:sel | Approved add: sel]. "Rectangle" #("in class, instance creation" center:extent: encompassing: left:right:top:bottom: merging: origin:corner: origin:extent: "accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight "comparing" "rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth: "testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide "truncation and round off" "transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying" ) do: [:sel | Approved add: sel]. "Color" #("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range: "named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow "other" colorNames indexedColors pixelScreenForDepth: quickHighLight: "access" alpha blue brightness green hue luminance red saturation "equality" "queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor "transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with: "groups of shades" darkShades: lightShades: mix:shades: wheel: "printing" shortPrintString "other" colorForInsets rgbTriplet "conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32 "private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying" ) do: [:sel | Approved add: sel]. " For each selector that requires a block argument, add (selector argNum) to the set Blocks." "ourClasses _ #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color). ourClasses do: [:clsName | cls _ Smalltalk at: clsName. (cls selectors) do: [:aSel | ((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [ (cls formalParametersAt: aSel) withIndexDo: [:tName :ind | (tName endsWith: 'Block') ifTrue: [ Blocks add: (Array with: aSel with: ind)]]]]]. " #((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (ifKindOf:thenDo: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray | Blocks add: anArray]. self initialize3. " MethodFinder new initialize. MethodFinder new organizationFiltered: TranslucentColor class " "Do not forget class messages for each of these classes" ! ! !MethodFinder methodsFor: 'initialize' stamp: 'tk 4/1/2002 11:33'! initialize3 "additional selectors to consider" #(asWords threeDigitName ) do: [:sel | Approved add: sel].! ! !MethodFinder methodsFor: 'initialize' stamp: 'NS 1/28/2004 11:19'! noteDangerous "Remember the methods with really bad side effects." Dangerous _ Set new. "Object accessing, testing, copying, dependent access, macpal, flagging" #(addInstanceVarNamed:withValue: haltIfNil copyAddedStateFrom: veryDeepCopy veryDeepCopyWith: veryDeepFixupWith: veryDeepInner: addDependent: evaluate:wheneverChangeIn: codeStrippedOut: playSoundNamed: isThisEverCalled isThisEverCalled: logEntry logExecution logExit) do: [:sel | Dangerous add: sel]. "Object error handling" #(cannotInterpret: caseError confirm: confirm:orCancel: doesNotUnderstand: error: halt halt: notify: notify:at: primitiveFailed shouldNotImplement subclassResponsibility tryToDefineVariableAccess:) do: [:sel | Dangerous add: sel]. "Object user interface" #(basicInspect beep inform: inspect inspectWithLabel: notYetImplemented inspectElement ) do: [:sel | Dangerous add: sel]. "Object system primitives" #(become: becomeForward: instVarAt:put: instVarNamed:put: nextInstance nextObject rootStubInImageSegment: someObject tryPrimitive:withArgs:) do: [:sel | Dangerous add: sel]. "Object private" #(errorImproperStore errorNonIntegerIndex errorNotIndexable errorSubscriptBounds: mustBeBoolean primitiveError: species storeAt:inTempFrame:) do: [:sel | Dangerous add: sel]. "Object, translation support" #(cCode: cCode:inSmalltalk: cCoerce:to: export: inline: returnTypeC: sharedCodeNamed:inCase: var:declareC:) do: [:sel | Dangerous add: sel]. "Object, objects from disk, finalization. And UndefinedObject" #(comeFullyUpOnReload: objectForDataStream: readDataFrom:size: rehash saveOnFile storeDataOn: actAsExecutor executor finalize retryWithGC:until: suspend) do: [:sel | Dangerous add: sel]. "No Restrictions: Boolean, False, True, " "Morph" #() do: [:sel | Dangerous add: sel]. "Behavior" #(obsolete confirmRemovalOf: copyOfMethodDictionary literalScannedAs:notifying: storeLiteral:on: addSubclass: removeSubclass: superclass: "creating method dictionary" addSelector:withMethod: compile: compile:notifying: compileAll compileAllFrom: compress decompile: defaultSelectorForMethod: methodDictionary: recompile:from: recompileChanges removeSelector: compressedSourceCodeAt: selectorAtMethod:setClass: allInstances allSubInstances inspectAllInstances inspectSubInstances thoroughWhichSelectorsReferTo:special:byte: "enumerating" allInstancesDo: allSubInstancesDo: allSubclassesDo: allSuperclassesDo: selectSubclasses: selectSuperclasses: subclassesDo: withAllSubclassesDo: "too slow->" crossReference removeUninstantiatedSubclassesSilently "too slow->" unreferencedInstanceVariables "private" becomeCompact becomeUncompact flushCache format:variable:words:pointers: format:variable:words:pointers:weak: printSubclassesOn:level: basicRemoveSelector: addSelector:withMethod:notifying: addSelectorSilently:withMethod:) do: [:sel | Dangerous add: sel]. "CompiledMethod" #(defaultSelector) do: [:sel | Dangerous add: sel]. "Others " #("no tangible result" do: associationsDo: "private" adaptToCollection:andSend: adaptToNumber:andSend: adaptToPoint:andSend: adaptToString:andSend: instVarAt:put: asDigitsToPower:do: combinations:atATimeDo: doWithIndex: pairsDo: permutationsDo: reverseDo: reverseWith:do: with:do: withIndexDo: asDigitsAt:in:do: combinationsAt:in:after:do: errorOutOfBounds permutationsStartingAt:do: fromUser) do: [:sel | Dangerous add: sel]. #( fileOutPrototype addSpareFields makeFileOutFile ) do: [:sel | Dangerous add: sel]. #(recompile:from: recompileAllFrom: recompileChanges asPrototypeWithFields: asPrototype addInstanceVarNamed:withValue: addInstanceVariable addClassVarName: removeClassVarName: findOrAddClassVarName: tryToDefineVariableAccess: instanceVariableNames: ) do: [:sel | Dangerous add: sel]. ! ! !MethodFinder methodsFor: 'initialize' stamp: 'md 12/6/2004 16:32'! test2: anArray "look for bad association" anArray do: [:sub | sub class == Association ifTrue: [ (#('true' '$a' '2' 'false') includes: sub value printString) ifFalse: [ self error: 'bad assn']. (#('3' '5.6' 'x' '''abcd''') includes: sub key printString) ifFalse: [ self error: 'bad assn']. ]. sub class == Array ifTrue: [ sub do: [:element | element class == String ifTrue: [element first asciiValue < 32 ifTrue: [ self error: 'store into string in data']]. element class == Association ifTrue: [ element value class == Association ifTrue: [ self error: 'bad assn']]]]. sub class == Date ifTrue: [sub year isInteger ifFalse: [ self error: 'stored into input date!!!!']]. sub class == Dictionary ifTrue: [ sub size > 0 ifTrue: [ self error: 'store into dictionary']]. sub class == OrderedCollection ifTrue: [ sub size > 4 ifTrue: [ self error: 'store into OC']]. ].! ! !MethodFinder methodsFor: 'initialize' stamp: 'tk 5/18/2001 19:18'! verify "Test a bunch of examples" " MethodFinder new verify " Approved ifNil: [self initialize]. "Sets of allowed selectors" (MethodFinder new load: #( (0) 0 (30) 0.5 (45) 0.707106 (90) 1) ) searchForOne asArray = #('data1 degreeSin') ifFalse: [self error: 'should have found it']. (MethodFinder new load: { { true. [3]. [4]}. 3. { false. [0]. [6]}. 6} ) searchForOne asArray = #('data1 ifTrue: data2 ifFalse: data3') ifFalse: [ self error: 'should have found it']. (MethodFinder new load: {#(1). true. #(2). false. #(5). true. #(10). false} ) searchForOne asArray = #('data1 odd') ifFalse: [self error: 'should have found it']. "will correct the date type of #true, and complain" (MethodFinder new load: #((4 2) '2r100' (255 16) '16rFF' (14 8) '8r16') ) searchForOne asArray = #('data1 radix: data2' 'data1 printStringBase: data2' 'data1 storeStringBase: data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: {{Point x: 3 y: 4}. 4. {Point x: 1 y: 5}. 5} ) searchForOne asArray = #('data1 y') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #(('abcd') $a ('TedK') $T) ) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d ) ) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 ) ) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it']. "note extra () needed for an Array object as an argument" (MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7) ) searchForOne asArray = #('data1 - data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612) ) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it']. (MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false} ) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((5) 0.2 (2) 0.5) ) searchForOne asArray = #('data1 reciprocal') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8) ) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args" ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639) ) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3) ) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((7) 2 (4) 2 ) ) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false} ) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((35) 3 (17) 1 (5) 5) ) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((36) 7 (50) 10 ) ) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [ self error: 'should have found it']. (MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 ) ) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [ self error: 'should have found it']. (MethodFinder new load: #((2) 8 (5) 17 ) ) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [ self error: 'should have found it']. ! ! !MethodFinder methodsFor: 'search' stamp: 'tk 4/12/2001 10:47'! insertConstants "see if one of several known expressions will do it. C is the constant we discover here." "C data1+C data1*C data1//C (data1*C1 + C2) (data1 = C) (data1 ~= C) (data1 <= C) (data1 >= C) (data1 mod C)" thisData size >= 2 ifFalse: [^ false]. "need 2 examples" (thisData at: 1) size = 1 ifFalse: [^ false]. "only one arg, data1" self const ifTrue: [^ true]. self constUsingData1Value ifTrue: [^ true]. "(data1 ?? const), where const is one of the values of data1" " == ~~ ~= = <= >= " self allNumbers ifFalse: [^ false]. self constMod ifTrue: [^ true]. self constPlus ifTrue: [^ true]. self constMult ifTrue: [^ true]. self constDiv ifTrue: [^ true]. self constLinear ifTrue: [^ true]. ^ false! ! !MethodFinder methodsFor: 'find a constant' stamp: 'md 11/14/2003 16:47'! constEquiv | const subTest got jj | "See if (data1 = C) or (data1 ~= C) is the answer" "quick test" ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 2 to: answers size do: [:ii | ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. const _ (thisData at: 1) at: 1. got _ (subTest _ MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifFalse: ["try other polarity for ~~ " (jj _ answers indexOf: (answers at: 1) not) > 0 ifTrue: [ const _ (thisData at: jj) at: 1. got _ (subTest _ MethodFinder new copy: self addArg: const) searchForOne isEmpty not]]. got ifFalse: [^ false]. "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true! ! !MethodFinder methodsFor: 'find a constant' stamp: 'tk 4/9/2001 17:59'! constUsingData1Value | const subTest got | "See if (data1 <= C) or (data1 >= C) is the answer" "quick test" ((answers at: 1) class superclass == Boolean) ifFalse: [^ false]. 2 to: answers size do: [:ii | ((answers at: ii) class superclass == Boolean) ifFalse: [^ false]]. thisData do: [:datums | const _ datums first. "use data as a constant!!" got _ (subTest _ MethodFinder new copy: self addArg: const) searchForOne isEmpty not. got ifTrue: [ "replace data2 with const in expressions" subTest expressions do: [:exp | expressions add: (exp copyReplaceAll: 'data2' with: const printString)]. selector addAll: subTest selectors. ^ true]]. ^ false! ! !MethodFinder class methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 23:34'! methodFor: dataAndAnswers "Return a Squeak expression that computes these answers. (This method is called by the comment in the bottom pane of a MethodFinder. Do not delete this method.)" | resultOC selFinder resultString | resultOC _ (self new) load: dataAndAnswers; findMessage. resultString _ String streamContents: [:strm | resultOC do: [:exp | strm nextPut: $(; nextPutAll: exp; nextPut: $); space]]. Smalltalk isMorphic ifTrue: [ selFinder _ (ActiveWorld submorphThat: [:mm | mm class == SystemWindow and: [mm model isKindOf: SelectorBrowser]] ifNone: [^ resultString]) model. selFinder searchResult: resultOC]. ^ resultString! ! !MethodHolder methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:54'! addModelMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph aCustomMenu addLine. aCustomMenu add: 'whose script is this?' translated target: self action: #identifyScript ! ! !MethodHolder methodsFor: 'menu' stamp: 'sw 12/12/2001 21:27'! doItReceiver "If there is an instance associated with me, answer it, for true mapping of self. If not, then do what other code-bearing tools do, viz. give access to the class vars." (self dependents detect: [:m | m isKindOf: MethodMorph]) ifNotNilDo: [:mm | (mm owner isKindOf: ScriptEditorMorph) ifTrue: [^ mm owner playerScripted]]. ^ self selectedClass ifNil: [FakeClassPool new]! ! !MethodHolder methodsFor: 'miscellaneous' stamp: 'sw 3/28/2002 00:36'! changeMethodSelectorTo: aSelector "Change my method selector as noted. Reset currentCompiledMethod" methodSelector _ aSelector. currentCompiledMethod _ methodClass compiledMethodAt: aSelector ifAbsent: [nil]! ! !MethodHolder methodsFor: 'contents' stamp: 'nk 6/19/2004 16:47'! contents "Answer the contents, with due respect for my contentsSymbol" contents _ methodClass sourceCodeAt: methodSelector ifAbsent: ['']. currentCompiledMethod _ methodClass compiledMethodAt: methodSelector ifAbsent: [nil]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContentsWithTempNames: Sensor leftShiftDown not ]. self showingDocumentation ifTrue: [^ self commentContents]. ^ contents _ self sourceStringPrettifiedAndDiffed asText makeSelectorBoldIn: methodClass! ! !MethodInterface methodsFor: 'attribute keywords' stamp: 'sw 5/4/2001 07:02'! selector: aSelector type: aType setter: aSetter "Set the receiver's fields as indicated. Values of nil or #none for the result type and the setter indicate that there is none" selector _ aSelector. (MethodInterface isNullMarker: aType) ifFalse: [resultSpecification _ ResultSpecification new. resultSpecification resultType: aType. (MethodInterface isNullMarker: aSetter) ifFalse: [resultSpecification companionSetterSelector: aSetter]]! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 3/10/2001 00:38'! argumentVariables "Answer the list of argumentVariables of the interface" ^ argumentVariables ifNil: [argumentVariables _ OrderedCollection new]! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 5/2/2001 21:19'! argumentVariables: variableList "Set the argument variables" argumentVariables _ variableList! ! !MethodInterface methodsFor: 'initialization' stamp: 'mir 7/12/2004 19:36'! conjuredUpFor: aSelector class: aClass "Initialize the receiver to have the given selector, obtaining whatever info one can from aClass. This basically covers the situation where no formal definition has been made." | parts | self initializeFor: aSelector. self wording: aSelector. receiverType _ #unknown. parts _ aClass formalHeaderPartsFor: aSelector. argumentVariables _ (1 to: selector numArgs) collect: [:anIndex | Variable new name: (parts at: (4 * anIndex)) type: #Object]. parts last isEmptyOrNil ifFalse: [self documentation: parts last]. ! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 3/9/2001 17:00'! initialize "Initialize the receiver" super initialize. attributeKeywords _ OrderedCollection new. defaultStatus _ #normal. argumentVariables _ OrderedCollection new ! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 2/24/2001 00:34'! initializeFor: aSelector "Initialize the receiver to have the given selector" selector _ aSelector. attributeKeywords _ OrderedCollection new. defaultStatus _ #normal ! ! !MethodInterface methodsFor: 'initialization' stamp: 'mir 7/12/2004 19:39'! initializeFromEToyCommandSpec: tuple category: aCategorySymbol "tuple holds an old etoy command-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to hold the same information" selector _ tuple second. receiverType _ #Player. selector numArgs == 1 ifTrue: [argumentVariables _ OrderedCollection with: (Variable new name: (Player formalHeaderPartsFor: selector) fourth type: tuple fourth)]. aCategorySymbol ifNotNil: [self flagAttribute: aCategorySymbol]. self wording: (ScriptingSystem wordingForOperator: selector); helpMessage: tuple third! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 8/9/2004 09:33'! initializeFromEToySlotSpec: tuple "tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to hold the same information" | setter | selector _ tuple seventh. self wording: (ScriptingSystem wordingForOperator: tuple second); helpMessage: tuple third. receiverType _ #Player. resultSpecification _ ResultSpecification new. resultSpecification resultType: tuple fourth. (#(getNewClone "seesColor: isOverColor:") includes: selector) ifTrue: [self setNotToRefresh] "actually should already be nil" ifFalse: [self setToRefetch]. ((tuple fifth == #readWrite) and: [((tuple size >= 9) and: [(setter _ tuple at: 9) ~~ #unused])]) ifTrue: [resultSpecification companionSetterSelector: setter]. "An example of an old slot-item spec: (slot numericValue 'A number representing the current position of the knob.' number readWrite Player getNumericValue Player setNumericValue:) 1 #slot 2 wording 3 balloon help 4 type 5 #readOnly or #readWrite 6 #Player (not used -- ignore) 7 getter selector 8 #Player (not used -- ignore) 9 setter selector " ! ! !MethodInterface methodsFor: 'initialization' stamp: 'mir 7/12/2004 19:40'! initializeSetterFromEToySlotSpec: tuple "tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to represent the getter of this item" selector _ tuple ninth. self wording: ('set ', tuple second); helpMessage: ('setter for', tuple third). receiverType _ #Player. argumentVariables _ Array with: (Variable new variableType: tuple fourth) ! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 3/7/2001 13:05'! receiverType: aType "set the receiver type. Whether the receiverType earns its keep here is not yet well understood. At the moment, this is unsent" receiverType _ aType! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 10/23/2001 05:42'! resultType: aType "Set the receiver's resultSpecification to be a ResultType of the given type" resultSpecification _ ResultSpecification new. resultSpecification resultType: aType! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 5/26/2001 22:59'! setNotToRefresh "Set the receiver up not to do periodic refresh." resultSpecification ifNotNil: [resultSpecification refetchFrequency: nil]! ! !MethodInterface methodsFor: 'initialization' stamp: 'sw 5/3/2001 15:59'! setToRefetch "Set the receiver up to expect a refetch, assuming it has a result specification" resultSpecification ifNotNil: [resultSpecification refetchFrequency: 1]! ! !MethodInterface methodsFor: 'access' stamp: 'sw 3/8/2001 16:29'! companionSetterSelector "If there is a companion setter selector, anwer it, else answer nil" ^ resultSpecification ifNotNil: [resultSpecification companionSetterSelector]! ! !MethodInterface methodsFor: 'access' stamp: 'sw 9/13/2001 16:42'! elementSymbol "Answer the element symbol, for the purposes of translation" ^ selector! ! !MethodInterface methodsFor: 'access' stamp: 'sw 2/24/2001 12:04'! receiverType "Answer the receiver type" ^ receiverType ifNil: [receiverType _ #unknown]! ! !MethodInterface methodsFor: 'access' stamp: 'sw 3/10/2001 00:38'! resultType "Answer the result type" ^ resultSpecification ifNotNil: [resultSpecification type] ifNil: [#unknown]! ! !MethodInterface methodsFor: 'access' stamp: 'sw 3/9/2001 17:02'! typeForArgumentNumber: anArgumentNumber "Answer the data type for the given argument number" | aVariable | aVariable _ self argumentVariables at: anArgumentNumber. ^ aVariable variableType! ! !MethodInterface methodsFor: 'access' stamp: 'sw 5/3/2001 01:10'! wantsReadoutInViewer "Answer whether the method represented by the receiver is one which should have a readout in a viewer" ^ resultSpecification notNil and: [resultSpecification refetchFrequency notNil]! ! !MethodInterface methodsFor: 'initialize-release' stamp: 'ar 3/3/2001 19:38'! releaseCachedState "Sent by player"! ! !MethodInterface methodsFor: 'printing' stamp: 'nk 8/20/2004 09:38'! printOn: aStream "print the receiver on a stream. Overridden to provide details about wording, selector, result type, and companion setter." super printOn: aStream. aStream nextPutAll: ' - wording: '; print: self wording; nextPutAll: ' selector: '; print: selector. self argumentVariables size > 0 ifTrue: [aStream nextPutAll: ' Arguments: '. argumentVariables doWithIndex: [:aVariable :anIndex | aStream nextPutAll: 'argument #', anIndex printString, ' name = ', aVariable variableName asString, ', type = ', aVariable variableType]]. resultSpecification ifNotNil: [aStream nextPutAll: ' result type = ', resultSpecification resultType asString. resultSpecification companionSetterSelector ifNotNil: [aStream nextPutAll: ' setter = ', resultSpecification companionSetterSelector asString]] ! ! !MethodInterface commentStamp: '<historical>' prior: 0! A MethodInterface describes the interface for a single method. The most generic form is not bound to any particular class or object but rather describes an idealized interface. selector A symbol - the selector being described argumentSpecifications A list of specifications for the formal arguments of the method resultSpecification A characterization of the return value of the method userLevel attributeKeywords A list of symbols, comprising keywords that the user wishes to see on the screen for this method defaultStatus The status to apply to new instances of the class by default (#ticking, #paused, #normal, etc.) ! !MethodInterface class methodsFor: 'utilities' stamp: 'sw 7/17/2001 19:08'! firingInterface "Answer an instance of the receiver representing #fire" ^ self new selector: #fire type: nil setter: nil! ! !MethodInterface class methodsFor: 'utilities' stamp: 'gk 3/1/2005 10:43'! isNullMarker: aMarker "Answer true if aMarker is nil or is one of the symbols in #(none #nil unused missing) -- to service a variety of historical conventions" ^ aMarker isNil or: [#(none #nil unused missing) includes: aMarker] " MethodInterface isNullMarker: nil MethodInterface isNullMarker: #nil MethodInterface isNullMarker: #none MethodInterface isNullMarker: #znak "! ! !MethodMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'! initialize "initialize the state of the receiver" super initialize. self useRoundedCorners! ! !MethodMorph methodsFor: 'scrolling' stamp: 'nk 4/28/2004 10:23'! showScrollBar "Copied down and modified to get rid of the ruinous comeToFront of the inherited version." | scriptor | (submorphs includes: scrollBar) ifTrue: [^ self]. self vResizeScrollBar. self privateAddMorph: scrollBar atIndex: 1. retractableScrollBar ifTrue: ["Bring the pane to the front so that it is fully visible" "self comeToFront. -- thanks but no thanks" (scriptor _ self ownerThatIsA: ScriptEditorMorph) ifNotNil: [scriptor comeToFront]] ifFalse: [self resetExtent]! ! !MethodMorph class methodsFor: 'as yet unclassified' stamp: 'dgd 8/26/2004 12:11'! defaultNameStemForInstances ^ 'Method'! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'! selector: symbol selectorOrFalse _ symbol! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'! sourceText: stringOrText sourceText _ stringOrText! ! !MethodNode methodsFor: 'code generation' stamp: 'ajh 3/24/2003 14:51'! generateNative: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." | blkSize nLits stack strm nArgs method | self generate: trailer ifQuick: [:m | method _ m. method cacheTempNames: self tempNames. ^ method]. nArgs _ arguments size. blkSize _ block sizeForEvaluatedValue: encoder. literals _ encoder allLiterals. (nLits _ literals size) > 255 ifTrue: [^self error: 'Too many literals referenced']. method _ CompiledMethod "Dummy to allocate right size" newBytes: blkSize trailerBytes: trailer nArgs: nArgs nTemps: encoder maxTemp nStack: 0 nLits: nLits primitive: primitive. strm _ ReadWriteStream with: method. strm position: method initialPC - 1. stack _ ParseStack new init. block emitForEvaluatedValue: stack on: strm. stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy']. strm position ~= (method size - trailer size) ifTrue: [^self error: 'Compiler code size discrepancy']. method needsFrameSize: stack size. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. method cacheTempNames: self tempNames. ^ method! ! !MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:25'! parserClass "Which parser produces this class of parse node" ^ Parser! ! !MethodNode methodsFor: 'code generation' stamp: 'yo 8/30/2002 14:07'! selector "Answer the message selector for the method represented by the receiver." (selectorOrFalse isSymbol) ifTrue: [^selectorOrFalse]. ^selectorOrFalse key. ! ! !MethodNode methodsFor: 'code generation' stamp: 'ajh 7/6/2003 15:26'! sourceMap "Answer a SortedCollection of associations of the form: pc (byte offset in me) -> sourceRange (an Interval) in source text." | methNode | methNode _ self. sourceText ifNil: [ "No source, use decompile string as source to map from" methNode _ self parserClass new parse: self decompileString class: self methodClass ]. methNode generateNative: #(0 0 0 0). "set bytecodes to map to" ^ methNode encoder sourceMap! ! !MethodNode methodsFor: 'converting' stamp: 'sw 5/20/2001 10:01'! asAltSyntaxText "Answer a string description of the parse tree whose root is the receiver, using the alternative syntax" ^ DialectStream dialect: #SQ00 contents: [:strm | self printOn: strm]! ! !MethodNode methodsFor: 'converting' stamp: 'sw 5/20/2001 10:00'! asColorizedSmalltalk80Text "Answer a colorized Smalltalk-80-syntax string description of the parse tree whose root is the receiver." ^ DialectStream dialect: #ST80 contents: [:strm | self printOn: strm]! ! !MethodNode methodsFor: 'printing' stamp: 'ajh 1/22/2003 17:39'! methodClass ^ encoder classEncoding! ! !MethodNode methodsFor: 'printing' stamp: 'ar 2/13/2001 21:15'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ primitive. primIndex = 0 ifTrue: [^ self]. primIndex = 120 ifTrue: ["External call spec" ^ aStream print: encoder literals first]. aStream nextPutAll: '<primitive: '. primIndex = 117 ifTrue: [primDecl _ encoder literals at: 1. aStream nextPut: $'; nextPutAll: (primDecl at: 2); nextPut: $'. (primDecl at: 1) notNil ifTrue: [aStream nextPutAll: ' module:'; nextPut: $'; nextPutAll: (primDecl at: 1); nextPut: $']] ifFalse: [aStream print: primIndex]. aStream nextPut: $>. Smalltalk at: #Interpreter ifPresent:[:cls| aStream nextPutAll: ' "' , ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" '].! ! !MethodNode methodsFor: 'printing' stamp: 'ajh 1/24/2003 17:41'! sourceText ^ sourceText ifNil: [self printString]! ! !MethodNode methodsFor: 'tiles' stamp: 'RAA 2/16/2001 15:44'! asMorphicSyntaxIn: parent ^parent methodNodeInner: self selectorOrFalse: selectorOrFalse precedence: precedence arguments: arguments temporaries: temporaries primitive: primitive block: block ! ! !MethodNode methodsFor: 'tiles' stamp: 'tk 8/5/2001 11:40'! asMorphicSyntaxUsing: aClass ^ Cursor wait showWhile: [ (aClass methodNodeOuter: self) finalAppearanceTweaks] ! ! !MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 07:42'! actualClass | actualClass | actualClass _ Smalltalk atOrBelow: classSymbol ifAbsent: [^nil]. classIsMeta ifTrue: [^actualClass class]. ^actualClass ! ! !MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 06:19'! asStringOrText ^stringVersion! ! !MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:11'! classIsMeta ^classIsMeta! ! !MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'! classSymbol ^classSymbol! ! !MethodReference methodsFor: 'queries' stamp: 'cwp 7/7/2003 17:44'! isValid "Answer whether the receiver represents a current selector or Comment" | aClass | (#(DoIt DoItIn:) includes: methodSymbol) ifTrue: [^ false]. (aClass _ self actualClass) ifNil: [^ false]. ^ (aClass includesSelector: methodSymbol) or: [methodSymbol == #Comment]! ! !MethodReference methodsFor: 'queries' stamp: 'RAA 5/28/2001 08:10'! methodSymbol ^methodSymbol! ! !MethodReference methodsFor: 'queries' stamp: 'sw 11/5/2001 00:53'! printOn: aStream "Print the receiver on a stream" super printOn: aStream. aStream nextPutAll: ' ', self actualClass name, ' >> ', methodSymbol! ! !MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 08:06'! setClass: aClass methodSymbol: methodSym stringVersion: aString classSymbol _ aClass theNonMetaClass name. classIsMeta _ aClass isMeta. methodSymbol _ methodSym. stringVersion _ aString.! ! !MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 07:34'! setClassAndSelectorIn: csBlock ^csBlock value: self actualClass value: methodSymbol! ! !MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 06:04'! setClassSymbol: classSym classIsMeta: isMeta methodSymbol: methodSym stringVersion: aString classSymbol _ classSym. classIsMeta _ isMeta. methodSymbol _ methodSym. stringVersion _ aString.! ! !MethodReference methodsFor: 'setting' stamp: 'RAA 5/28/2001 11:34'! setStandardClass: aClass methodSymbol: methodSym classSymbol _ aClass theNonMetaClass name. classIsMeta _ aClass isMeta. methodSymbol _ methodSym. stringVersion _ aClass name , ' ' , methodSym.! ! !MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'! stringVersion ^stringVersion! ! !MethodReference methodsFor: 'string version' stamp: 'RAA 5/29/2001 14:44'! stringVersion: aString stringVersion _ aString! ! !MethodReference methodsFor: 'comparisons' stamp: 'RAA 5/28/2001 11:56'! <= anotherMethodReference classSymbol < anotherMethodReference classSymbol ifTrue: [^true]. classSymbol > anotherMethodReference classSymbol ifTrue: [^false]. classIsMeta = anotherMethodReference classIsMeta ifFalse: [^classIsMeta not]. ^methodSymbol <= anotherMethodReference methodSymbol ! ! !MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/7/2003 13:18'! = anotherMethodReference "Answer whether the receiver and the argument represent the same object." ^ self species == anotherMethodReference species and: [self classSymbol = anotherMethodReference classSymbol] and: [self classIsMeta = anotherMethodReference classIsMeta] and: [self methodSymbol = anotherMethodReference methodSymbol]! ! !MethodReference methodsFor: 'comparisons' stamp: 'dgd 3/8/2003 11:54'! hash "Answer a SmallInteger whose value is related to the receiver's identity." ^ (self species hash bitXor: self classSymbol hash) bitXor: self methodSymbol hash! ! !MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'! category ^ self actualClass organization categoryOfElement: methodSymbol! ! !MethodReference methodsFor: '*packageinfo-base' stamp: 'ab 5/23/2003 22:58'! sourceCode ^ self actualClass sourceCodeAt: methodSymbol! ! !MethodReference methodsFor: '*PrimCallController' stamp: 'sr 6/14/2004 15:11'! compiledMethod ^ self actualClass compiledMethodAt: methodSymbol! ! !MethodReference methodsFor: '*PrimCallController' stamp: 'sr 6/4/2004 01:55'! sourceString ^ (self actualClass sourceCodeAt: self methodSymbol) asString! ! !MethodReferenceTest methodsFor: 'Running' stamp: 'dgd 3/8/2003 11:48'! testEquals | aMethodReference anotherMethodReference | aMethodReference _ MethodReference new. anotherMethodReference _ MethodReference new. " two fresh instances should be equals between them" self should: [aMethodReference = anotherMethodReference]. self should: [aMethodReference hash = anotherMethodReference hash]. " two instances representing the same method (same class and same selector) should be equals" aMethodReference setStandardClass: String methodSymbol: #foo. anotherMethodReference setStandardClass: String methodSymbol: #foo. self should: [aMethodReference = anotherMethodReference]. self should: [aMethodReference hash = anotherMethodReference hash] ! ! !MethodReferenceTest methodsFor: 'Running' stamp: 'dgd 3/8/2003 11:48'! testNotEquals | aMethodReference anotherMethodReference | aMethodReference _ MethodReference new. anotherMethodReference _ MethodReference new. "" aMethodReference setStandardClass: String methodSymbol: #foo. anotherMethodReference setStandardClass: String class methodSymbol: #foo. " differente classes, same selector -> no more equals" self shouldnt: [aMethodReference = anotherMethodReference]. " same classes, diferente selector -> no more equals" anotherMethodReference setStandardClass: String methodSymbol: #bar. self shouldnt: [aMethodReference = anotherMethodReference] ! ! !MethodWithInterface methodsFor: 'access' stamp: 'sw 3/28/2001 16:25'! playerClass "Answer the playerClass associated with the receiver. Note: fixes up cases where the playerClass slot was a Playerxxx object because of an earlier bug" ^ (playerClass isKindOf: Class) ifTrue: [playerClass] ifFalse: [playerClass _ playerClass class]! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/30/2001 11:37'! convertFromUserScript: aUserScript "The argument represents an old UserScript object. convert it over" defaultStatus _ aUserScript status.! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 1/26/2001 16:44'! initialize "Initialize the receiver by setting its inst vars to default values" super initialize. defaultStatus _ #normal! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 2/20/2001 03:29'! isTextuallyCoded "Answer whether the receiver is in a textually-coded state. A leftover from much earlier times, this is a vacuous backstop" ^ false! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'sw 9/12/2001 11:59'! playerClass: aPlayerClass selector: aSelector "Set the playerClass and selector of the receiver" playerClass _ aPlayerClass. selector _ aSelector.! ! !MethodWithInterface methodsFor: 'initialization' stamp: 'nk 7/2/2004 07:18'! status ^defaultStatus ! ! !MethodWithInterface methodsFor: 'rename' stamp: 'sw 2/17/2001 04:10'! okayToRename "Answer whether the receiver is in a state to be renamed." ^ true! ! !MethodWithInterface methodsFor: 'rename' stamp: 'sw 3/11/2003 00:01'! renameScript: newSelector fromPlayer: aPlayer "The receiver's selector has changed to the new selector. Get various things right, including the physical appearance of any Scriptor open on this method" self allScriptEditors do: [:aScriptEditor | aScriptEditor renameScriptTo: newSelector]. (selector numArgs = 0 and: [newSelector numArgs = 1]) ifTrue: [self argumentVariables: (OrderedCollection with: (Variable new name: #parameter type: #Number))]. (selector numArgs = 1 and: [newSelector numArgs = 0]) ifTrue: [self argumentVariables: OrderedCollection new]. selector _ newSelector asSymbol. self bringUpToDate. self playerClass atSelector: selector putScript: self. self allScriptActivationButtons do: [:aButton | aButton bringUpToDate]. ! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/10/2003 23:58'! allScriptActivationButtons "Answer all the script-activation buttons that exist for this interface" ^ ScriptActivationButton allInstances select: [:aButton | aButton uniclassScript == self]! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/28/2001 16:26'! allScriptEditors "Answer all the script editors that exist for the class and selector of this interface" ^ ScriptEditorMorph allInstances select: [:aScriptEditor | aScriptEditor playerScripted class == self playerClass and: [aScriptEditor scriptName == selector]]! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 2/17/2001 03:28'! currentScriptEditor: anEditor "Set the receiver's currentScriptEditor as indicated, if I care. MethodWithInterface does not care, since it does not hold on to a ScriptEditor. A subclass of mine, however does, or did, care"! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 3/28/2001 16:26'! instantiatedScriptEditorForPlayer: aPlayer "Return a new script editor for the player and selector" | aScriptEditor | aScriptEditor _ (self playerClass includesSelector: selector) ifTrue: [ScriptEditorMorph new fromExistingMethod: selector forPlayer: aPlayer] ifFalse: [ScriptEditorMorph new setMorph: aPlayer costume scriptName: selector]. defaultStatus == #ticking ifTrue: [aPlayer costume arrangeToStartStepping]. ^ aScriptEditor! ! !MethodWithInterface methodsFor: 'script editor' stamp: 'sw 7/28/2001 01:00'! recompileScriptFromTilesUnlessTextuallyCoded "Recompile Script From Tiles Unless Textually Coded. For the universal-tiles MethodWithInterface case, this is moot. Used only in support of a reintegration of Open-school forked projects from Sept 2000 in 7/01"! ! !MethodWithInterface methodsFor: 'updating' stamp: 'sw 3/28/2001 16:26'! bringUpToDate "Bring all scriptors related to this method up to date. Note that this will not change the senders of this method if the selector changed -- that's something still ahead." (ScriptEditorMorph allInstances select: [:m | (m playerScripted isMemberOf: self playerClass) and: [m scriptName == selector]]) do: [:m | m bringUpToDate]! ! !MethodWithInterface methodsFor: 'updating' stamp: 'sw 2/20/2001 03:43'! revertToLastSavedTileVersionFor: anEditor "revert to the last saved tile version. Only for universal tiles." anEditor removeAllButFirstSubmorph. anEditor insertUniversalTiles. anEditor showingMethodPane: false! ! !MethodWithInterface methodsFor: 'updating' stamp: 'sw 2/20/2001 03:41'! saveScriptVersion: timeStamp "Save the tile script version if I do that sort of thing"! ! !MethodWithInterface commentStamp: '<historical>' prior: 0! A MethodInterface bound to an actual class. selector A symbol - the selector being described argumentSpecifications A list of specifications for the formal arguments of the method resultSpecification A characterization of the return value of the method userLevel attributeKeywords A list of symbols, comprising keywords that the user wishes to associate with this method defaultStatus The status to apply to new instances of the class by default defaultFiresPerTick How many fires per tick, by default, should be allowed if ticking. playerClass The actual class with which this script is associated! !MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/28/2003 00:00'! atChannel: channelIndex from: aPopUpChoice selectInstrument: selection | oldSnd name snd instSelector | oldSnd := midiSynth instrumentForChannel: channelIndex. (selection beginsWith: 'edit ') ifTrue: [name := selection copyFrom: 6 to: selection size. aPopUpChoice contentsClipped: name. (oldSnd isKindOf: FMSound) | (oldSnd isKindOf: LoopedSampledSound) ifTrue: [EnvelopeEditorMorph openOn: oldSnd title: name]. (oldSnd isKindOf: SampledInstrument) ifTrue: [EnvelopeEditorMorph openOn: oldSnd allNotes first title: name]. ^self]. snd := nil. 1 to: instrumentSelector size do: [:i | (channelIndex ~= i and: [(instSelector := instrumentSelector at: i) notNil and: [selection = instSelector contents]]) ifTrue: [snd := midiSynth instrumentForChannel: i]]. "use existing instrument prototype" snd ifNil: [snd := (selection = 'clink' ifTrue: [(SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025)] ifFalse: [(AbstractSound soundNamed: selection) ])copy ]. midiSynth instrumentForChannel: channelIndex put: snd. (instrumentSelector at: channelIndex) contentsClipped: selection! ! !MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'dgd 9/19/2003 13:33'! invokeMenu "Invoke a menu of additonal commands." | aMenu | aMenu _ CustomMenu new. aMenu add: 'add channel' translated action: #addChannel. aMenu add: 'reload instruments' translated target: AbstractSound selector: #updateScorePlayers. midiSynth isOn ifFalse: [ aMenu add: 'set MIDI port' translated action: #setMIDIPort. midiSynth midiPort ifNotNil: [aMenu add: 'close MIDI port' translated action: #closeMIDIPort]]. aMenu invokeOn: self defaultSelection: nil. ! ! !MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 17:51'! makeControls | bb r reverbSwitch onOffSwitch | bb _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2; color: color. r _ AlignmentMorph newRow. r color: bb color; borderWidth: 0; layoutInset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r addMorphBack: ( bb label: '<>'; actWhen: #buttonDown; actionSelector: #invokeMenu). onOffSwitch _ SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; label: 'On'; actionSelector: #toggleOnOff; target: self; setSwitchState: false. r addMorphBack: onOffSwitch. reverbSwitch _ SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; label: 'Reverb Disable'; actionSelector: #disableReverb:; target: self; setSwitchState: SoundPlayer isReverbOn not. r addMorphBack: reverbSwitch. ^ r ! ! !MidiInputMorph methodsFor: 'as yet unclassified' stamp: 'tk 2/19/2001 18:43'! panAndVolControlsFor: channelIndex | volSlider panSlider c r middleLine | volSlider _ SimpleSliderMorph new color: color; extent: 101@2; target: midiSynth; arguments: (Array with: channelIndex); actionSelector: #volumeForChannel:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (midiSynth volumeForChannel: channelIndex). panSlider _ SimpleSliderMorph new color: color; extent: 101@2; target: midiSynth; arguments: (Array with: channelIndex); actionSelector: #panForChannel:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (midiSynth panForChannel: channelIndex). c _ AlignmentMorph newColumn color: color; layoutInset: 0; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #spaceFill; vResizing: #shrinkWrap. middleLine _ Morph new "center indicator for pan slider" color: (Color r: 0.4 g: 0.4 b: 0.4); extent: 1@(panSlider height - 4); position: panSlider center x@(panSlider top + 2). panSlider addMorphBack: middleLine. r _ self makeRow. r addMorphBack: (StringMorph contents: '0'). r addMorphBack: volSlider. r addMorphBack: (StringMorph contents: '10'). c addMorphBack: r. r _ self makeRow. r addMorphBack: (StringMorph contents: 'L'). r addMorphBack: panSlider. r addMorphBack: (StringMorph contents: 'R'). c addMorphBack: r. ^ c ! ! !MidiInputMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !MidiInputMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !MidiInputMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:24'! initialize "initialize the state of the receiver" super initialize. "" self listDirection: #topToBottom; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #spaceFill; vResizing: #spaceFill; layoutInset: 3. midiPortNumber _ nil. midiSynth _ MIDISynth new. instrumentSelector _ Array new: 16. self removeAllMorphs. self addMorphBack: self makeControls. self addMorphBack: (AlignmentMorph newColumn color: color; layoutInset: 0). self addChannelControlsFor: 1. self extent: 20 @ 20! ! !MidiPrimTester class methodsFor: 'class initialization' stamp: 'yo 12/3/2004 17:05'! initialize "Initialize the MIDI parameter constants." "MidiPrimTester initialize" Installed _ 1. "Read-only. Return 1 if a MIDI driver is installed, 0 if not. On OMS-based MIDI drivers, this returns 1 only if the OMS system is properly installed and configured." Version _ 2. "Read-only. Return the integer version number of this MIDI driver. The version numbering sequence is relative to a particular driver. That is, version 3 of the Macintosh MIDI driver is not necessarily related to version 3 of the Win95 MIDI driver." HasBuffer _ 3. "Read-only. Return 1 if this MIDI driver has a time-stamped output buffer, 0 otherwise. Such a buffer allows the client to schedule MIDI output packets to be sent later. This can allow more precise timing, since the driver uses timer interrupts to send the data at the right time even if the processor is in the midst of a long-running Squeak primitive or is running some other application or system task." HasDurs _ 4. "Read-only. Return 1 if this MIDI driver supports an extended primitive for note-playing that includes the note duration and schedules both the note-on and the note-off messages in the driver. Otherwise, return 0." CanSetClock _ 5. "Read-only. Return 1 if this MIDI driver's clock can be set via an extended primitive, 0 if not." CanUseSemaphore _ 6. "Read-only. Return 1 if this MIDI driver can signal a semaphore when MIDI input arrives. Otherwise, return 0. If this driver supports controller caching and it is enabled, then incoming controller messages will not signal the semaphore." EchoOn _ 7. "Read-write. If this flag is set to a non-zero value, and if the driver supports echoing, then incoming MIDI events will be echoed immediately. If this driver does not support echoing, then queries of this parameter will always return 0 and attempts to change its value will do nothing." UseControllerCache _ 8. "Read-write. If this flag is set to a non-zero value, and if the driver supports a controller cache, then the driver will maintain a cache of the latest value seen for each MIDI controller, and control update messages will be filtered out of the incoming MIDI stream. An extended MIDI primitive allows the client to poll the driver for the current value of each controller. If this driver does not support a controller cache, then queries of this parameter will always return 0 and attempts to change its value will do nothing." EventsAvailable _ 9. "Read-only. Return the number of MIDI packets in the input queue." FlushDriver _ 10. "Write-only. Setting this parameter to any value forces the driver to flush its I/0 buffer, discarding all unprocessed data. Reading this parameter returns 0. Setting this parameter will do nothing if the driver does not support buffer flushing." ClockTicksPerSec _ 11. "Read-only. Return the MIDI clock rate in ticks per second." HasInputClock _ 12. "Read-only. Return 1 if this MIDI driver timestamps incoming MIDI data with the current value of the MIDI clock, 0 otherwise. If the driver does not support such timestamping, then the client must read input data frequently and provide its own timestamping." ! ! !MixedSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:23'! isStereo ^ true ! ! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 12:51'! atEnd: aBoolean atEnd := aBoolean.! ! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:29'! inStream ^inStream! ! !MockSocketStream methodsFor: 'accessing' stamp: 'fbs 3/22/2004 13:08'! outStream ^outStream! ! !MockSocketStream methodsFor: 'initialize-release' stamp: 'fbs 3/22/2004 13:29'! initialize self resetInStream. self resetOutStream.! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:10'! nextLine ^self nextLineCrLf! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! nextLineCrLf ^(self upToAll: String crlf).! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:28'! resetInStream inStream := WriteStream on: ''.! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! upToAll: delims ^self inStream upToAll: delims.! ! !MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:28'! resetOutStream outStream := WriteStream on: ''.! ! !MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:07'! sendCommand: aString self outStream nextPutAll: aString; nextPutAll: String crlf.! ! !MockSocketStream methodsFor: 'testing' stamp: 'fbs 3/22/2004 13:08'! atEnd ^self inStream atEnd.! ! !MockSocketStream class methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'! on: socket ^self basicNew initialize! ! !ModalSystemWindowView methodsFor: 'modal dialog' stamp: 'BG 12/13/2002 11:33'! doModalDialog | savedArea | self resizeInitially. self resizeTo: ((self windowBox) align: self windowBox center with: Display boundingBox aboveCenter). savedArea _ Form fromDisplay: self windowBox. self displayEmphasized. self controller startUp. self release. savedArea displayOn: Display at: self windowOrigin. ! ! !Model methodsFor: 'dependents' stamp: 'sw 2/6/2001 04:13'! containingWindow "Answer the window that holds the receiver. The dependents technique is odious and may not be airtight, if multiple windows have the same model." ^ self dependents detect: [:d | ((d isKindOf: SystemWindow orOf: StandardSystemView) or: [d isKindOf: MVCWiWPasteUpMorph]) and: [d model == self]] ifNone: [nil]! ! !Model methodsFor: 'dependents' stamp: 'gm 2/16/2003 20:37'! topView "Find the first top view on me. Is there any danger of their being two with the same model? Any danger from ungarbage collected old views? Ask if schedulled?" dependents ifNil: [^nil]. Smalltalk isMorphic ifTrue: [dependents do: [:v | ((v isSystemWindow) and: [v isInWorld]) ifTrue: [^v]]. ^nil]. dependents do: [:v | v superView ifNil: [v model == self ifTrue: [^v]]]. ^nil! ! !Model methodsFor: 'text links' stamp: 'RAA 5/29/2001 11:14'! addItem: classAndMethod "Make a linked message list and put this method in it" | list | self flag: #mref. "classAndMethod is a String" MessageSet parse: classAndMethod toClassAndSelector: [ :class :sel | class ifNil: [^self]. list _ OrderedCollection with: ( MethodReference new setClass: class methodSymbol: sel stringVersion: classAndMethod ). MessageSet openMessageList: list name: 'Linked by HyperText'. ] ! ! !Model methodsFor: 'menus' stamp: 'zz 3/2/2004 23:49'! step "Default for morphic models is no-op"! ! !Model methodsFor: 'keyboard' stamp: 'nk 6/29/2004 14:46'! arrowKey: aChar from: view "backstop; all the PluggableList* classes actually handle arrow keys, and the models handle other keys." ^false! ! !Model methodsFor: 'copying' stamp: 'tk 10/21/2002 12:59'! veryDeepFixupWith: deepCopier "See if the dependents are being copied also. If so, point at the new copies. (The dependent has self as its model.) Dependents handled in class Object, when the model is not a Model, are fixed up in Object veryDeepCopy." | originalDependents refs newDependent | super veryDeepFixupWith: deepCopier. originalDependents _ dependents. originalDependents ifNil: [ ^self. ]. dependents _ nil. refs _ deepCopier references. originalDependents do: [:originalDependent | newDependent _ refs at: originalDependent ifAbsent: []. newDependent ifNotNil: [self addDependent: newDependent]]! ]style[(29 206 19 395)f1b,f1,f1LObject veryDeepCopy;,f1! ! !Model methodsFor: 'copying' stamp: 'RB 9/20/2001 16:25'! veryDeepInner: deepCopier "Shallow copy dependents and fix them later" ! ! !Model commentStamp: '<historical>' prior: 0! Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintenance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:30'! classVarNames ^ item classVarNames asSet! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:29'! instVarNames ^ item instVarNames asSet! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:30'! oldClassVarNames ^ oldItem classVarNames asSet! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:29'! oldInstVarNames ^ oldItem instVarNames asSet! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'! oldSharedPools ^ oldItem sharedPools! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'! oldSuperclass ^ oldItem superclass! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:31'! sharedPools ^ item sharedPools! ! !ModifiedClassDefinitionEvent methodsFor: 'accessing' stamp: 'NS 1/20/2004 19:28'! superclass ^ item superclass! ! !ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/26/2004 09:33'! anyChanges ^ self isSuperclassModified or: [self areInstVarsModified or: [self areClassVarsModified or: [self areSharedPoolsModified]]]! ! !ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:31'! areClassVarsModified ^ self classVarNames ~= self oldClassVarNames! ! !ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:30'! areInstVarsModified ^ self instVarNames ~= self oldInstVarNames! ! !ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:32'! areSharedPoolsModified ^ self sharedPools ~= self oldSharedPools! ! !ModifiedClassDefinitionEvent methodsFor: 'testing' stamp: 'NS 1/20/2004 19:29'! isSuperclassModified ^ item superclass ~~ oldItem superclass! ! !ModifiedClassDefinitionEvent methodsFor: 'printing' stamp: 'NS 1/21/2004 09:25'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' Super: '; print: self isSuperclassModified; nextPutAll: ' InstVars: '; print: self areInstVarsModified; nextPutAll: ' ClassVars: '; print: self areClassVarsModified; nextPutAll: ' SharedPools: '; print: self areSharedPoolsModified.! ! !ModifiedClassDefinitionEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 11:52'! classDefinitionChangedFrom: oldClass to: newClass | instance | instance := self item: newClass kind: self classKind. instance oldItem: oldClass. ^instance! ! !ModifiedClassDefinitionEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:26'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind! ! !ModifiedEvent methodsFor: 'testing' stamp: 'NS 1/19/2004 15:09'! isModified ^true! ! !ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 15:10'! printEventKindOn: aStream aStream nextPutAll: 'Modified'! ! !ModifiedEvent methodsFor: 'printing' stamp: 'NS 1/19/2004 17:57'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' oldItem: '; print: oldItem.! ! !ModifiedEvent methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:08'! oldItem ^ oldItem! ! !ModifiedEvent methodsFor: 'private-accessing' stamp: 'NS 1/19/2004 15:08'! oldItem: anItem oldItem _ anItem! ! !ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/19/2004 15:10'! changeKind ^#Modified! ! !ModifiedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:25'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! !ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/20/2004 19:37'! classDefinitionChangedFrom: oldClass to: newClass ^ ModifiedClassDefinitionEvent classDefinitionChangedFrom: oldClass to: newClass! ! !ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'! methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass | instance | instance := self method: newMethod selector: aSymbol class: aClass. instance oldItem: oldMethod. ^ instance! ! !ModifiedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 11:40'! methodChangedFrom: oldMethod to: newMethod selector: aSymbol inClass: aClass requestor: requestor | instance | instance := self method: newMethod selector: aSymbol class: aClass requestor: requestor. instance oldItem: oldMethod. ^ instance! ! !Monitor methodsFor: 'synchronization' stamp: 'NS 4/14/2004 13:13'! critical: aBlock "Critical section. Executes aBlock as a critical section. At any time, only one process can be executing code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!!" | result | [self enter. result _ aBlock value] ensure: [self exit]. ^ result.! ! !Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:55'! wait "Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed." ^ self waitMaxMilliseconds: nil! ! !Monitor methodsFor: 'waiting-basic' stamp: 'NS 7/1/2002 21:56'! waitUntil: aBlock "Conditional waiting for the default event. See Monitor>>waitWhile: aBlock." ^ self waitUntil: aBlock for: nil! ! !Monitor methodsFor: 'waiting-basic' stamp: 'fbs 3/24/2004 14:39'! waitWhile: aBlock "Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again..." ^ self waitWhile: aBlock for: nil! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 21:58'! waitFor: aSymbolOrNil "Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event." ^ self waitFor: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! waitUntil: aBlock for: aSymbolOrNil "Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock." ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'waiting-specific' stamp: 'NS 7/1/2002 22:01'! waitWhile: aBlock for: aSymbolOrNil "Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event." ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: nil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:03'! waitFor: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitFor:, but the process gets automatically woken up when the specified time has passed." self checkOwnerProcess. self waitInQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! waitFor: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitFor:, but the process gets automatically woken up when the specified time has passed." ^ self waitFor: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:04'! waitMaxMilliseconds: anIntegerOrNil "Same as Monitor>>wait, but the process gets automatically woken up when the specified time has passed." ^ self waitFor: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitMaxSeconds: aNumber "Same as Monitor>>wait, but the process gets automatically woken up when the specified time has passed." ^ self waitMaxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: [aBlock value not] for: aSymbolOrNil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock for: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitUntil:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:05'! waitUntil: aBlock maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitUntil: aBlock maxSeconds: aNumber "Same as Monitor>>waitUntil:, but the process gets automatically woken up when the specified time has passed." ^ self waitUntil: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the specified time has passed." self checkOwnerProcess. self waitWhile: aBlock inQueue: (self queueFor: aSymbolOrNil) maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock for: aSymbolOrNil maxSeconds: aNumber "Same as Monitor>>waitWhile:for:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock for: aSymbolOrNil maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock maxMilliseconds: anIntegerOrNil "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock for: nil maxMilliseconds: anIntegerOrNil! ! !Monitor methodsFor: 'waiting-timeout' stamp: 'NS 7/1/2002 22:06'! waitWhile: aBlock maxSeconds: aNumber "Same as Monitor>>waitWhile:, but the process gets automatically woken up when the specified time has passed." ^ self waitWhile: aBlock maxMilliseconds: (aNumber * 1000) asInteger! ! !Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! signal "One process waiting for the default event is woken up." ^ self signal: nil! ! !Monitor methodsFor: 'signaling-default' stamp: 'NS 7/1/2002 21:57'! signalAll "All processes waiting for the default event are woken up." ^ self signalAll: nil! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 4/13/2004 15:12'! signal: aSymbolOrNil "One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed." | queue | self checkOwnerProcess. queue _ self queueFor: aSymbolOrNil. queue isEmpty ifTrue: [queue _ self defaultQueue]. self signalQueue: queue.! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! signalAll: aSymbolOrNil "All process waiting for the given event or the default event are woken up." | queue | self checkOwnerProcess. queue _ self queueFor: aSymbolOrNil. self signalAllInQueue: self defaultQueue. queue ~~ self defaultQueue ifTrue: [self signalAllInQueue: queue].! ! !Monitor methodsFor: 'signaling-specific' stamp: 'NS 7/1/2002 22:02'! signalReallyAll "All processes waiting for any events (default or specific) are woken up." self checkOwnerProcess. self signalAll. self queueDict valuesDo: [:queue | self signalAllInQueue: queue].! ! !Monitor methodsFor: 'accessing' stamp: 'NS 7/1/2002 20:02'! cleanup self checkOwnerProcess. self critical: [self privateCleanup].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:40'! checkOwnerProcess self isOwnerProcess ifFalse: [self error: 'Monitor access violation'].! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:06'! defaultQueue defaultQueue ifNil: [defaultQueue _ OrderedCollection new]. ^ defaultQueue! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:37'! enter self isOwnerProcess ifTrue: [ nestingLevel _ nestingLevel + 1. ] ifFalse: [ mutex wait. ownerProcess _ Processor activeProcess. nestingLevel _ 1. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 13:38'! exit nestingLevel _ nestingLevel - 1. nestingLevel < 1 ifTrue: [ ownerProcess _ nil. mutex signal ].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:32'! exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil | lock delay | queuesMutex critical: [lock _ anOrderedCollection addLast: Semaphore new]. self exit. anIntegerOrNil isNil ifTrue: [ lock wait ] ifFalse: [ delay _ MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection. lock wait. delay unschedule. ]. self enter.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:42'! isOwnerProcess ^ Processor activeProcess == ownerProcess! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:14'! privateCleanup queuesMutex critical: [ defaultQueue isEmpty ifTrue: [defaultQueue _ nil]. queueDict ifNotNil: [ queueDict copy keysAndValuesDo: [:id :queue | queue isEmpty ifTrue: [queueDict removeKey: id]]. queueDict isEmpty ifTrue: [queueDict _ nil]. ]. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:10'! queueDict queueDict ifNil: [queueDict _ IdentityDictionary new]. ^ queueDict.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:12'! queueFor: aSymbol aSymbol ifNil: [^ self defaultQueue]. ^ self queueDict at: aSymbol ifAbsent: [self queueDict at: aSymbol put: OrderedCollection new].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'! signalAllInQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection do: [:lock | lock signal]. anOrderedCollection removeAllSuchThat: [:each | true]. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:34'! signalLock: aSemaphore inQueue: anOrderedCollection queuesMutex critical: [ aSemaphore signal. anOrderedCollection remove: aSemaphore ifAbsent: []. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 4/13/2004 16:10'! signalQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection isEmpty ifTrue: [^ self]. anOrderedCollection removeFirst signal. ].! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil [aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! ! !Monitor methodsFor: 'initialize-release' stamp: 'NS 4/13/2004 16:12'! initialize mutex _ Semaphore forMutualExclusion. queuesMutex _ Semaphore forMutualExclusion. nestingLevel _ 0.! ! !Monitor commentStamp: 'fbs 3/24/2004 14:41' prior: 0! A monitor provides process synchronization that is more high level than the one provided by a Semaphore. Similar to the classical definition of a Monitor it has the following properties: 1) At any time, only one process can execute code inside a critical section of a monitor. 2) A monitor is reentrant, which means that the active process in a monitor never gets blocked when it enters a (nested) critical section of the same monitor. 3) Inside a critical section, a process can wait for an event that may be coupled to a certain condition. If the condition is not fulfilled, the process leaves the monitor temporarily (in order to let other processes enter) and waits until another process signals the event. Then, the original process checks the condition again (this is often necessary because the state of the monitor could have changed in the meantime) and continues if it is fulfilled. 4) The monitor is fair, which means that the process that is waiting on a signaled condition the longest gets activated first. 5) The monitor allows you to define timeouts after which a process gets activated automatically. Basic usage: Monitor>>critical: aBlock Critical section. Executes aBlock as a critical section. At any time, only one process can execute code in a critical section. NOTE: All the following synchronization operations are only valid inside the critical section of the monitor!! Monitor>>wait Unconditional waiting for the default event. The current process gets blocked and leaves the monitor, which means that the monitor allows another process to execute critical code. When the default event is signaled, the original process is resumed. Monitor>>waitWhile: aBlock Conditional waiting for the default event. The current process gets blocked and leaves the monitor only if the argument block evaluates to true. This means that another process can enter the monitor. When the default event is signaled, the original process is resumed, which means that the condition (argument block) is checked again. Only if it evaluates to false, does execution proceed. Otherwise, the process gets blocked and leaves the monitor again... Monitor>>waitUntil: aBlock Conditional waiting for the default event. See Monitor>>waitWhile: aBlock. Monitor>>signal One process waiting for the default event is woken up. Monitor>>signalAll All processes waiting for the default event are woken up. Using non-default (specific) events: Monitor>>waitFor: aSymbol Unconditional waiting for the non-default event represented by the argument symbol. Same as Monitor>>wait, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitWhile: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. Same as Monitor>>waitWhile:for:, but the process gets only reactivated by the specific event and not the default event. Monitor>>waitUntil: aBlock for: aSymbol Confitional waiting for the non-default event represented by the argument symbol. See Monitor>>waitWhile:for: aBlock. Monitor>>signal: aSymbol One process waiting for the given event is woken up. If there is no process waiting for this specific event, a process waiting for the default event gets resumed. Monitor>>signalAll: aSymbol All process waiting for the given event or the default event are woken up. Monitor>>signalReallyAll All processes waiting for any events (default or specific) are woken up. Using timeouts Monitor>>waitMaxMilliseconds: anInteger Monitor>>waitFor: aSymbol maxMilliseconds: anInteger Same as Monitor>>wait (resp. Monitor>>waitFor:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitWhile: aBlock maxMilliseconds: anInteger Monitor>>waitWhile: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitWhile: (resp. Monitor>>waitWhile:for:), but the process gets automatically woken up when the specified time has passed. Monitor>>waitUntil: aBlock maxMilliseconds: anInteger Monitor>>waitUntil: aBlock for: aSymbol maxMilliseconds: anInteger Same as Monitor>>waitUntil: (resp. Monitor>>waitUntil:for:), but the process gets automatically woken up when the specified time has passed. Usage examples See code in class MBoundedCounter and compare it to the clumsy BoundedCounter that is written wihout a monitor.! !MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:26'! setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection monitor _ aMonitor. queue _ anOrderedCollection. self setDelay: anInteger forSemaphore: aSemaphore.! ! !MonitorDelay methodsFor: 'private' stamp: 'NS 4/13/2004 16:22'! signalWaitingProcess "The delay time has elapsed; signal the waiting process." beingWaitedOn _ false. monitor signalLock: delaySemaphore inQueue: queue. ! ! !MonitorDelay commentStamp: 'NS 4/13/2004 16:51' prior: 0! This is a specialization of the class Delay that is used for the implementation of the class Monitor.! !MonitorDelay class methodsFor: 'instance creation' stamp: 'NS 4/13/2004 16:25'! signalLock: aSemaphore afterMSecs: anInteger inMonitor: aMonitor queue: anOrderedCollection anInteger < 0 ifTrue: [self error: 'delay times cannot be negative']. ^ (self new setDelay: anInteger forSemaphore: aSemaphore monitor: aMonitor queue: anOrderedCollection) schedule! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:04'! asMonth ^ self ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! daysInMonth ^ self duration days.! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! index ^ self monthIndex ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! name ^ self monthName ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! previous ^ self class starting: (self start - 1) ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! printOn: aStream aStream nextPutAll: self monthName, ' ', self year printString.! ! !Month methodsFor: 'deprecated' stamp: 'brp 8/5/2003 22:08'! eachWeekDo: aBlock self deprecated: 'Use #weeksDo:'. self weeksDo: aBlock ! ! !Month commentStamp: 'brp 5/13/2003 09:48' prior: 0! I represent a month.! !Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:22'! month: month year: year "Create a Month for the given <year> and <month>. <month> may be a number or a String with the name of the month. <year> should be with 4 digits." ^ self starting: (DateAndTime year: year month: month day: 1) ! ! !Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:21'! readFrom: aStream | m y c | m _ (ReadWriteStream with: '') reset. [(c _ aStream next) isSeparator] whileFalse: [m nextPut: c]. [(c _ aStream next) isSeparator] whileTrue. y _ (ReadWriteStream with: '') reset. y nextPut: c. [aStream atEnd] whileFalse: [y nextPut: aStream next]. ^ self month: m contents year: y contents "Month readFrom: 'July 1998' readStream" ! ! !Month class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:59'! starting: aDateAndTime duration: aDuration "Override - a each month has a defined duration" | start adjusted days | start _ aDateAndTime asDateAndTime. adjusted _ DateAndTime year: start year month: start month day: 1. days _ self daysInMonth: adjusted month forYear: adjusted year. ^ super starting: adjusted duration: (Duration days: days)! ! !Month class methodsFor: 'smalltalk-80' stamp: 'brp 7/27/2003 16:27'! daysInMonth: indexOrName forYear: yearInteger | index | index _ indexOrName isInteger ifTrue: [indexOrName] ifFalse: [self indexOfMonth: indexOrName]. ^ (DaysInMonth at: index) + ((index = 2 and: [Year isLeapYear: yearInteger]) ifTrue: [1] ifFalse: [0])! ! !Month class methodsFor: 'smalltalk-80' stamp: 'brp 8/23/2003 09:29'! indexOfMonth: aMonthName 1 to: 12 do: [ :i | (aMonthName, '*' match: (MonthNames at: i)) ifTrue: [^i] ]. self error: aMonthName , ' is not a recognized month name'.! ! !Month class methodsFor: 'smalltalk-80' stamp: 'brp 5/13/2003 09:02'! nameOfMonth: anIndex ^ MonthNames at: anIndex.! ! !MonthMorph methodsFor: 'controls' stamp: 'brp 9/3/2003 08:46'! chooseYear | newYear yearString | newYear _ (SelectionMenu selections: {'today'} , (month year - 5 to: month year + 5) , {'other...'}) startUpWithCaption: 'Choose another year'. newYear ifNil: [^ self]. newYear isNumber ifTrue: [^ self month: (Month month: month monthName year: newYear)]. newYear = 'today' ifTrue: [^ self month: (Month starting: Date today)]. yearString _ FillInTheBlank request: 'Type in a year' initialAnswer: Date today year asString. yearString ifNil: [^ self]. newYear _ yearString asNumber. (newYear between: 0 and: 9999) ifTrue: [^ self month: (Month month: month monthName year: newYear)]. ! ! !MonthMorph methodsFor: 'controls' stamp: 'brp 1/13/2004 11:33'! nextYear self month: (Month month: month month year: month year + 1) ! ! !MonthMorph methodsFor: 'controls' stamp: 'brp 1/13/2004 11:33'! previousYear self month: (Month month: month month year: month year - 1) ! ! !MonthMorph methodsFor: 'controls' stamp: 'nk 7/30/2004 17:54'! startMondayOrSundayString ^(Week startDay ifTrue: ['start Sunday'] ifFalse: ['start Monday']) translated! ! !MonthMorph methodsFor: 'controls' stamp: 'brp 9/2/2003 15:14'! toggleStartMonday (Week startDay = #Monday) ifTrue: [ Week startDay: #Sunday ] ifFalse: [ Week startDay: #Monday ]. self initializeWeeks ! ! !MonthMorph methodsFor: 'initialization' stamp: 'brp 9/2/2003 15:14'! defaultColor "answer the default color/fill style for the receiver" ^ Color red! ! !MonthMorph methodsFor: 'initialization' stamp: 'brp 9/2/2003 15:14'! initialize "initialize the state of the receiver" super initialize. "" tileRect _ 0 @ 0 extent: 23 @ 19. self layoutInset: 1; listDirection: #topToBottom; vResizing: #shrinkWrap; hResizing: #shrinkWrap; month: Month current. self rubberBandCells: false. self extent: 160 @ 130! ! !MonthMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:17'! initializeHeader | title sep frame button monthName | title := (self findA: WeekMorph) title. title hResizing: #spaceFill. "should be done by WeekMorph but isn't" title submorphsDo: [:m | m hResizing: #spaceFill]. monthName := month name. self width < 160 ifTrue: [monthName := (#(6 7 9) includes: month index) ifTrue: [monthName copyFrom: 1 to: 4] ifFalse: [monthName copyFrom: 1 to: 3]]. sep := (Morph new) color: Color transparent; extent: title width @ 1. self addMorph: sep; addMorph: title; addMorph: sep copy. button := (SimpleButtonMorph new) target: self; actWhen: #whilePressed; color: (Color r: 0.8 g: 0.8 b: 0.8). frame := (AlignmentMorph new) color: Color transparent; listDirection: #leftToRight; hResizing: #spaceFill; vResizing: #shrinkWrap; layoutInset: 0. frame addMorph: (button label: '>>'; actionSelector: #nextYear; width: 15); addMorph: ((button copy) label: '>'; actionSelector: #next; width: 15); addMorph: (((AlignmentMorph new) color: Color transparent; listDirection: #topToBottom; wrapCentering: #center; cellPositioning: #topCenter; extent: (title fullBounds width - (button width * 3)) @ title height) addMorph: (StringMorph new contents: monthName , ' ' , month year printString)); addMorph: ((button copy) label: '<'; actionSelector: #previous; width: 15); addMorph: ((button copy) label: '<<'; actionSelector: #previousYear; width: 15). "hResizing: #shrinkWrap;" self addMorph: frame! ! !MonthMorph methodsFor: 'initialization' stamp: 'brp 9/3/2003 08:52'! initializeWeeks | weeks | self removeAllMorphs. weeks _ OrderedCollection new. month weeksDo: [ :w | weeks add: (WeekMorph newWeek: w month: month tileRect: tileRect model: model)]. weeks reverseDo: [ :w | w hResizing: #spaceFill; vResizing: #spaceFill. "should be done by WeekMorph but isn't" w submorphsDo:[ :m | m hResizing: #spaceFill; vResizing: #spaceFill ]. self addMorph: w ]. self initializeHeader; highlightToday. ! ! !MonthMorph methodsFor: 'all' stamp: 'dgd 8/30/2003 21:53'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine; addUpdating: #startMondayOrSundayString action: #toggleStartMonday; add: 'jump to year...' translated action: #chooseYear.! ! !MonthMorph commentStamp: '<historical>' prior: 0! A widget that displays the dates of a month in a table.! !MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:52'! testConverting self assert: month asDate = '1 July 1998' asDate! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 8/5/2003 22:43'! testDeprecated self assert: month firstDate = '1 July 1998' asDate; assert: month lastDate = '31 July 1998' asDate.! ! !MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testEnumerating | weeks | weeks := OrderedCollection new. month eachWeekDo: [:w | weeks add: w firstDate]. 0 to: 4 do: [:i | weeks remove: (Week starting: ('29 June 1998' asDate addDays: i * 7)) firstDate]. self assert: weeks isEmpty! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 8/23/2003 16:08'! testInquiries self assert: month index = 7; assert: month name = #July; assert: month duration = (31 days). ! ! !MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testInstanceCreation | m1 m2 | m1 := Month starting: '4 July 1998' asDate. m2 := Month month: #July year: 1998. self assert: month = m1; assert: month = m2! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 23:02'! testPreviousNext | n p | n := month next. p := month previous. self assert: n year = 1998; assert: n index = 8; assert: p year = 1998; assert: p index = 6. ! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:50'! testPrinting self assert: month printString = 'July 1998'. ! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:46'! testReadFrom | m | m := Month readFrom: 'July 1998' readStream. self assert: m = month! ! !MonthTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'! classToBeTested ^ Month! ! !MonthTest methodsFor: 'Coverage' stamp: 'brp 7/26/2003 23:29'! selectorsToBeIgnored | deprecated private special | deprecated := #(). private := #( #printOn: ). special := #( #next ). ^ super selectorsToBeIgnored, deprecated, private, special.! ! !MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'! setUp super setUp. month _ Month month: 7 year: 1998.! ! !MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'! tearDown super tearDown. month _ nil.! ! !MonthTest commentStamp: 'brp 7/26/2003 22:44' prior: 0! This is the unit test for the class Month. ! !Morph methodsFor: '*StandardYellowButtonMenus-event handling' stamp: 'nk 3/10/2004 19:48'! handlerForYellowButtonDown: anEvent "Return the (prospective) handler for a mouse down event with the yellow button pressed. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event." (self hasYellowButtonMenu or: [ self handlesMouseDown: anEvent ]) ifFalse: [ ^ nil]. "Not interested." anEvent handler ifNil: [^ self]. "Nobody else was interested" "Same priority but I am innermost." ^ self mouseDownPriority >= anEvent handler mouseDownPriority ifFalse: [nil ] ifTrue: [self]! ! !Morph methodsFor: '*StandardYellowButtonMenus-event handling' stamp: 'nk 6/24/2004 13:19'! yellowButtonActivity: shiftState "Find me or my outermost owner that has items to add to a yellow button menu. shiftState is true if the shift was pressed. Otherwise, build a menu that contains the contributions from myself and my interested submorphs, and present it to the user." | aMenu outerOwner | outerOwner := self outermostOwnerWithYellowButtonMenu. outerOwner ifNil: [ ^self ]. outerOwner ~~ self ifTrue: [^outerOwner yellowButtonActivity: shiftState ]. aMenu := MenuMorph new defaultTarget: self. aMenu addTitle: self externalName. self addNestedYellowButtonItemsTo: aMenu event: ActiveEvent. aMenu popUpInWorld: self currentWorld. ! ! !Morph methodsFor: '*StandardYellowButtonMenus-event handling-override' stamp: 'nk 3/10/2004 19:47'! handlerForMouseDown: anEvent "Return the (prospective) handler for a mouse down event. The handler is temporarily installed and can be used for morphs further down the hierarchy to negotiate whether the inner or the outer morph should finally handle the event." anEvent blueButtonPressed ifTrue: [^ self handlerForBlueButtonDown: anEvent]. anEvent yellowButtonPressed ifTrue: [^ self handlerForYellowButtonDown: anEvent]. anEvent controlKeyPressed ifTrue: [^ self handlerForMetaMenu: anEvent]. (self handlesMouseDown: anEvent) ifFalse: [^ nil]. "not interested" anEvent handler ifNil: [^ self ]. "Same priority but I am innermost" "Nobody else was interested" ^self mouseDownPriority >= anEvent handler mouseDownPriority ifTrue: [ self] ifFalse: [ nil]! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 6/15/2004 07:11'! addGraphModelYellowButtonItemsTo: aCustomMenu event: evt ^aCustomMenu! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 6/15/2004 07:23'! addModelYellowButtonItemsTo: aCustomMenu event: evt "Give my models a chance to add their context-menu items to aCustomMenu." self model ifNotNilDo: [ :m | m addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: self hand: evt hand. aCustomMenu addLine]. ^aCustomMenu! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 3/10/2004 19:49'! addMyYellowButtonMenuItemsToSubmorphMenus "Answer true if I have items to add to the context menus of my submorphs" ^true! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 3/10/2004 19:45'! addNestedYellowButtonItemsTo: aMenu event: evt "Add items to aMenu starting with me and proceeding down through my submorph chain, letting any submorphs that include the event position contribute their items to the bottom of the menu, separated by a line." self addYellowButtonMenuItemsTo: aMenu event: evt. (self submorphThat: [:m | m containsPoint: evt position] ifNone: []) ifNotNilDo: [:m | | submenu | (m addMyYellowButtonMenuItemsToSubmorphMenus and: [m hasYellowButtonMenu]) ifTrue: [aMenu addLine. submenu := MenuMorph new defaultTarget: m. m addNestedYellowButtonItemsTo: submenu event: evt. aMenu add: m externalName subMenu: submenu]]! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 3/10/2004 19:50'! addYellowButtonMenuItemsTo: aCustomMenu event: evt "Populate aCustomMenu with appropriate menu items for a yellow-button (context menu) click." aCustomMenu defaultTarget: self; addStayUpItem. self addModelYellowButtonItemsTo: aCustomMenu event: evt! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 3/10/2004 19:50'! hasYellowButtonMenu "Answer true if I have any items at all for a context (yellow button) menu." ^self models anySatisfy: [ :m | m hasModelYellowButtonMenuItems ]! ! !Morph methodsFor: '*StandardYellowButtonMenus-menus' stamp: 'nk 3/10/2004 19:51'! outermostOwnerWithYellowButtonMenu "Answer me or my outermost owner that is willing to contribute menu items to a context menu. Don't include the world." | outermost | outermost _ self outermostMorphThat: [ :ea | ea isWorldMorph not and: [ ea hasYellowButtonMenu ]]. ^outermost ifNil: [ self hasYellowButtonMenu ifTrue: [ self ] ifFalse: []] ! ! !Morph methodsFor: '*StandardYellowButtonMenus-model access' stamp: 'nk 3/10/2004 19:51'! models "Answer a collection of whatever models I may have." self modelOrNil ifNil: [ ^EmptyArray ]. ^Array with: self modelOrNil! ! !Morph methodsFor: '*connectors-dropping/grabbing' stamp: 'sw 7/27/2002 01:45'! slideToTrash: evt "Perhaps slide the receiver across the screen to a trash can and make it disappear into it. In any case, remove the receiver from the screen." | aForm trash startPoint endPoint morphToSlide | ((self renderedMorph == Utilities scrapsBook) or: [self renderedMorph isKindOf: TrashCanMorph]) ifTrue: [self delete. ^ self]. Preferences slideDismissalsToTrash ifTrue: [morphToSlide _ self representativeNoTallerThan: 200 norWiderThan: 200 thumbnailHeight: 100. aForm _ morphToSlide imageForm offset: (0@0). trash _ ActiveWorld findDeepSubmorphThat: [:aMorph | (aMorph isKindOf: TrashCanMorph) and: [aMorph topRendererOrSelf owner == ActiveWorld]] ifAbsent: [trash _ TrashCanMorph new. trash position: ActiveWorld bottomLeft - (0 @ (trash extent y + 26)). trash openInWorld. trash]. endPoint _ trash fullBoundsInWorld center. startPoint _ self topRendererOrSelf fullBoundsInWorld center - (aForm extent // 2)]. self delete. ActiveWorld displayWorld. Preferences slideDismissalsToTrash ifTrue: [aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15]. Utilities addToTrash: self! ! !Morph methodsFor: '*connectors-naming' stamp: 'dgd 8/30/2003 15:52'! innocuousName "Choose an innocuous name for the receiver -- one that does not end in the word Morph" | className allKnownNames | className _ self defaultNameStemForInstances. (className size > 5 and: [className endsWith: 'Morph']) ifTrue: [className _ className copyFrom: 1 to: className size - 5]. className _ className asString translated. allKnownNames _ self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames]. ^ Utilities keyLike: className asString satisfying: [:aName | (allKnownNames includes: aName) not]! ! !Morph methodsFor: '*connectors-submorphs-add/remove' stamp: 'sw 4/19/2002 22:56'! dismissViaHalo "The user has clicked in the delete halo-handle. This provides a hook in case some concomitant action should be taken, or if the particular morph is not one which should be put in the trash can, for example." Preferences preserveTrash ifFalse: [^ self dismissMorph: ActiveEvent]. TrashCanMorph moveToTrash: self! ! !Morph methodsFor: '*connectors-testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^false! ! !Morph methodsFor: '*connectors-testing' stamp: 'dvf 8/23/2003 11:50'! renameTo: aName "Set Player name in costume. Update Viewers. Fix all tiles (old style). fix References. New tiles: recompile, and recreate open scripts. If coming in from disk, and have name conflict, References will already have new name. " | aPresenter putInViewer aPasteUp renderer oldKey assoc classes oldName | oldName := self knownName. (renderer := self topRendererOrSelf) setNameTo: aName. putInViewer := false. ((aPresenter := self presenter) isNil or: [renderer player isNil]) ifFalse: [putInViewer := aPresenter currentlyViewing: renderer player. putInViewer ifTrue: [renderer player viewerFlapTab hibernate]]. "empty it temporarily" (aPasteUp := self topPasteUp) ifNotNil: [aPasteUp allTileScriptingElements do: [:m | m bringUpToDate]]. "Fix References dictionary. See restoreReferences to know why oldKey is already aName, but oldName is the old name." oldKey := References keyAtIdentityValue: renderer player ifAbsent: []. oldKey ifNotNil: [assoc := References associationAt: oldKey. oldKey = aName ifFalse: ["normal rename" assoc key: (renderer player uniqueNameForReferenceFrom: aName). References rehash]]. putInViewer ifTrue: [aPresenter viewMorph: self]. "recreate my viewer" oldKey ifNil: [^aName]. "Force strings in tiles to be remade with new name. New tiles only." Preferences universalTiles ifFalse: [^aName]. classes := (self systemNavigation allCallsOn: assoc) collect: [:each | each classSymbol]. classes asSet do: [:clsName | (Smalltalk at: clsName) replaceSilently: oldName to: aName]. "replace in text body of all methods. Can be wrong!!" "Redo the tiles that are showing. This is also done in caller in unhibernate. " aPasteUp ifNotNil: [aPasteUp allTileScriptingElements do: [:mm | "just ScriptEditorMorphs" nil. (mm isKindOf: ScriptEditorMorph) ifTrue: [((mm playerScripted class compiledMethodAt: mm scriptName) hasLiteral: assoc) ifTrue: [mm hibernate; unhibernate]]]]. ^aName! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/24/2003 17:31'! instantiatedUserScriptsDo: aBlock self actorStateOrNil ifNotNilDo: [ :aState | aState instantiatedUserScriptsDictionary do: aBlock]! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/25/2003 11:36'! removeAllEventTriggers "Remove all the event registrations for my Player. User custom events are triggered at the World, while system custom events are triggered on individual Morphs." | player | (player _ self player) ifNil: [ ^self ]. self removeAllEventTriggersFor: player. self currentWorld removeAllEventTriggersFor: player.! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/24/2003 17:46'! removeAllEventTriggersFor: aPlayer "Remove all the event registrations for aPlayer. User custom events are triggered at the World, while system custom events are triggered on individual Morphs." self removeActionsSatisfying: [:action | action receiver == aPlayer and: [(#(#doScript: #triggerScript:) includes: action selector) ]].! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/25/2003 11:37'! removeEventTrigger: aSymbol "Remove all the event registrations for my Player that are triggered by aSymbol. User custom events are triggered at the World, while system custom events are triggered on individual Morphs." | player | (player _ self player) ifNil: [ ^self ]. self removeEventTrigger: aSymbol for: player. self currentWorld removeEventTrigger: aSymbol for: player.! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/25/2003 11:24'! removeEventTrigger: aSymbol for: aPlayer "Remove all the event registrations for aPlayer that are triggered by aSymbol. User custom events are triggered at the World, while system custom events are triggered on individual Morphs." self removeActionsSatisfying: [:action | action receiver == aPlayer and: [(#(#doScript: #triggerScript: ) includes: action selector) and: [action arguments first == aSymbol]]]! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 9/25/2003 11:11'! renameScriptActionsFor: aPlayer from: oldSelector to: newSelector self updateableActionMap keysAndValuesDo: [ :event :sequence | sequence asActionSequence do: [ :action | ((action receiver == aPlayer) and: [ (#(doScript: triggerScript:) includes: action selector) and: [ action arguments first == oldSelector ]]) ifTrue: [ action arguments at: 1 put: newSelector ]]] ! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 11/1/2004 11:00'! triggerCustomEvent: aSymbol "Trigger whatever scripts may be connected to the custom event named aSymbol" self currentWorld triggerEtoyEvent: aSymbol from: self! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 11/1/2004 10:54'! triggerEtoyEvent: aSymbol "Trigger whatever scripts may be connected to the event named aSymbol. If anyone comes back to ask who sent it, return our player." [ self triggerEvent: aSymbol ] on: GetTriggeringObjectNotification do: [ :ex | ex isNested ifTrue: [ ex pass ] ifFalse: [ ex resume: self assuredPlayer ]] ! ! !Morph methodsFor: '*customevents-scripting' stamp: 'nk 11/1/2004 10:58'! triggerEtoyEvent: aSymbol from: aMorph "Trigger whatever scripts may be connected to the event named aSymbol. If anyone comes back to ask who sent it, return aMorph's player." [ self triggerEvent: aSymbol ] on: GetTriggeringObjectNotification do: [ :ex | ex isNested ifTrue: [ ex pass ] ifFalse: [ ex resume: aMorph assuredPlayer ]] ! ! !Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 17:12'! categoriesForViewer "Answer a list of symbols representing the categories to offer in the viewer, in order" | dict aList | dict := Dictionary new. self unfilteredCategoriesForViewer withIndexDo: [:cat :index | dict at: cat put: index]. self filterViewerCategoryDictionary: dict. aList := SortedCollection sortBlock: [:a :b | (dict at: a) < (dict at: b)]. aList addAll: dict keys. ^ aList asArray! ! !Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 17:09'! selectorsForViewer "Answer a list of symbols representing all the selectors available in all my viewer categories" | aClass aList itsAdditions added addBlock | aClass := self renderedMorph class. aList := OrderedCollection new. added := Set new. addBlock := [ :sym | (added includes: sym) ifFalse: [ added add: sym. aList add: sym ]]. [aClass == Morph superclass] whileFalse: [(aClass hasAdditionsToViewerCategories) ifTrue: [itsAdditions := aClass allAdditionsToViewerCategories. itsAdditions do: [ :add | add do: [:aSpec | "the spec list" aSpec first == #command ifTrue: [ addBlock value: aSpec second]. aSpec first == #slot ifTrue: [ addBlock value: (aSpec seventh). addBlock value: aSpec ninth]]]]. aClass := aClass superclass]. ^aList copyWithoutAll: #(#unused #dummy) "SimpleSliderMorph basicNew selectorsForViewer"! ! !Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 17:14'! selectorsForViewerIn: aCollection "Answer a list of symbols representing all the selectors available in all my viewer categories, selecting only the ones in aCollection" | aClass aList itsAdditions added addBlock | aClass := self renderedMorph class. aList := OrderedCollection new. added := Set new. addBlock := [ :sym | (added includes: sym) ifFalse: [ (aCollection includes: sym) ifTrue: [ added add: sym. aList add: sym ]]]. [aClass == Morph superclass] whileFalse: [(aClass hasAdditionsToViewerCategories) ifTrue: [itsAdditions := aClass allAdditionsToViewerCategories. itsAdditions do: [ :add | add do: [:aSpec | "the spec list" aSpec first == #command ifTrue: [ addBlock value: aSpec second]. aSpec first == #slot ifTrue: [ addBlock value: (aSpec seventh). addBlock value: aSpec ninth]]]]. aClass := aClass superclass]. ^aList copyWithoutAll: #(#unused #dummy) "SimpleSliderMorph basicNew selectorsForViewerIn: #(setTruncate: getColor setColor: getKnobColor setKnobColor: getWidth setWidth: getHeight setHeight: getDropEnabled setDropEnabled:) "! ! !Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/4/2004 11:47'! understandsBorderVocabulary "Replace the 'isKindOf: BorderedMorph' so that (for instance) Connectors can have their border vocabulary visible in viewers." ^false! ! !Morph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 17:31'! unfilteredCategoriesForViewer "Answer a list of symbols representing the categories to offer in the viewer, in order of: - masterOrderingOfCategorySymbols first - others last in order by translated wording" " Morph basicNew unfilteredCategoriesForViewer " ^self renderedMorph class unfilteredCategoriesForViewer. ! ! !Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 09:58'! allowsGestureStart: evt ^false! ! !Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:45'! isGestureStart: anEvent "This mouse down could be the start of a gesture, or the end of a gesture focus" anEvent hand isGenieEnabled ifFalse: [ ^false ]. (self allowsGestureStart: anEvent) ifTrue: [^ true ]. "could be the start of a gesture" "otherwise, check for whether it's time to disable the Genie auto-focus" (anEvent hand isGenieFocused and: [anEvent whichButton ~= anEvent hand focusStartEvent whichButton]) ifTrue: [anEvent hand disableGenieFocus]. ^false! ! !Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/11/2004 17:30'! mouseStillDownStepRate "At what rate do I want to receive #mouseStillDown: notifications?" ^1! ! !Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 06:38'! redButtonGestureDictionaryOrName: aSymbolOrDictionary! ! !Morph methodsFor: '*geniestubs-stubs' stamp: 'nk 3/10/2004 06:38'! yellowButtonGestureDictionaryOrName: aSymbolOrDictionary! ! !Morph methodsFor: '*morphic-Postscript Canvases' stamp: 'nk 12/29/2003 10:55'! printPSToFile self printPSToFileNamed: self externalName! ! !Morph methodsFor: 'WiW support' stamp: 'RAA 2/16/2001 13:57'! addMorphInFrontOfLayer: aMorph | targetLayer layerHere | targetLayer _ aMorph morphicLayerNumberWithin: self. submorphs do: [ :each | each == aMorph ifTrue: [^self]. layerHere _ each morphicLayerNumberWithin: self. "the <= is the difference - it insures we go to the front of our layer" targetLayer <= layerHere ifTrue: [ ^self addMorph: aMorph inFrontOf: each ]. ]. self addMorphBack: aMorph. ! ! !Morph methodsFor: 'WiW support' stamp: 'gk 5/24/2004 15:43'! eToyRejectDropMorph: morphToDrop event: evt | tm am | tm _ TextMorph new beAllFont: ((TextStyle named: Preferences standardEToysFont familyName) fontOfSize: 24); contents: 'GOT IT!!'. (am _ AlignmentMorph new) color: Color yellow; layoutInset: 10; useRoundedCorners; vResizing: #shrinkWrap; hResizing: #shrinkWrap; addMorph: tm; fullBounds; position: (self bounds center - (am extent // 2)); openInWorld: self world. SoundService default playSoundNamed: 'yum' ifAbsentReadFrom: 'yum.aif'. morphToDrop rejectDropMorphEvent: evt. "send it back where it came from" am delete ! ! !Morph methodsFor: 'WiW support' stamp: 'RAA 2/16/2001 13:54'! morphicLayerNumberWithin: anOwner "helpful for insuring some morphs always appear in front of or behind others. smaller numbers are in front" ^(owner isNil or: [owner isWorldMorph or: [anOwner == owner]]) ifTrue: [ self valueOfProperty: #morphicLayerNumber ifAbsent: [100] ] ifFalse: [ owner morphicLayerNumber ]. "leave lots of room for special things"! ! !Morph methodsFor: 'WiW support' stamp: 'ar 3/18/2001 00:14'! shouldGetStepsFrom: aWorld ^self world == aWorld! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:52'! actorState: anActorState "change the receiver's actorState" self assureExtension actorState: anActorState! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:56'! actorStateOrNil "answer the redeiver's actorState" ^ self hasExtension ifTrue: [self extension actorState]! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'! adoptPaneColor: paneColor self submorphsDo:[:m| m adoptPaneColor: paneColor].! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 14:27'! balloonText "Answer balloon help text or nil, if no help is available. NB: subclasses may override such that they programatically construct the text, for economy's sake, such as model phrases in a Viewer" | text balloonSelector aString | self hasExtension ifFalse: [^nil]. (text := self extension balloonText) ifNotNil: [^text]. (balloonSelector := self extension balloonTextSelector) ifNotNil: [aString := ScriptingSystem helpStringOrNilFor: balloonSelector. (aString isNil and: [balloonSelector == #methodComment]) ifTrue: [aString := self methodCommentAsBalloonHelp]. ((aString isNil and: [balloonSelector numArgs = 0]) and: [self respondsTo: balloonSelector]) ifTrue: [aString := self perform: balloonSelector]]. ^aString ifNotNil: [aString asString withNoLineLongerThan: Preferences maxBalloonHelpLineLength]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:42'! balloonTextSelector "Answer balloon text selector item in the extension, nil if none" ^ self hasExtension ifTrue: [self extension balloonTextSelector]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:50'! balloonTextSelector: aSelector "change the receiver's balloonTextSelector" self assureExtension balloonTextSelector: aSelector! ! !Morph methodsFor: 'accessing' stamp: 'sw 10/31/2001 21:06'! beFlap: aBool "Mark the receiver with the #flap property, or unmark it" aBool ifTrue: [self setProperty: #flap toValue: true. self hResizing: #rigid. self vResizing: #rigid] ifFalse: [self removeProperty: #flap]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! beSticky "make the receiver sticky" self assureExtension sticky: true! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:22'! beUnsticky "If the receiver is marked as sticky, make it now be unsticky" self hasExtension ifTrue: [self extension sticky: false]! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderColor ^self borderStyle color! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 10:55'! borderColor: aColorOrSymbolOrNil "Unfortunately, the argument to borderColor could be more than just a color. It could also be a symbol, in which case it is to be interpreted as a style identifier. But I might not be able to draw that kind of border, so it may have to be ignored. Or it could be nil, in which case I should revert to the default border." | style newStyle | style := self borderStyle. style baseColor = aColorOrSymbolOrNil ifTrue: [^ self]. aColorOrSymbolOrNil isColor ifTrue: [style style = #none "default border?" ifTrue: [self borderStyle: (SimpleBorder width: 0 color: aColorOrSymbolOrNil)] ifFalse: [style baseColor: aColorOrSymbolOrNil. self changed]. ^ self]. self borderStyle: ( ({ nil. #none } includes: aColorOrSymbolOrNil) ifTrue: [BorderStyle default] ifFalse: [ "a symbol" self doesBevels ifFalse: [ ^self ]. newStyle := (BorderStyle perform: aColorOrSymbolOrNil) color: style color; width: style width; yourself. (self canDrawBorder: newStyle) ifTrue: [newStyle] ifFalse: [style]])! ! !Morph methodsFor: 'accessing' stamp: 'ar 11/26/2001 14:53'! borderStyle ^(self valueOfProperty: #borderStyle ifAbsent:[BorderStyle default]) trackColorFrom: self! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/11/2001 22:14'! borderStyle: newStyle newStyle = self borderStyle ifFalse:[ (self canDrawBorder: newStyle) ifFalse:[ "Replace the suggested border with a simple one" ^self borderStyle: (BorderStyle width: newStyle width color: (newStyle trackColorFrom: self) color)]. self setProperty: #borderStyle toValue: newStyle. self changed].! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:18'! borderStyleForSymbol: aStyleSymbol "Answer a suitable BorderStyle for me of the type represented by a given symbol" | aStyle existing | aStyle _ BorderStyle borderStyleForSymbol: aStyleSymbol asSymbol. aStyle ifNil: [self error: 'bad style']. existing _ self borderStyle. aStyle width: existing width; baseColor: existing baseColor. ^ (self canDrawBorder: aStyle) ifTrue: [aStyle] ifFalse: [nil]! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderWidth ^self borderStyle width! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/14/2004 17:48'! borderWidth: aNumber | style | style _ self borderStyle. style width = aNumber ifTrue: [ ^self ]. style style = #none ifTrue: [ self borderStyle: (SimpleBorder width: aNumber color: Color transparent) ] ifFalse: [ style width: aNumber. self changed ]. ! ! !Morph methodsFor: 'accessing' stamp: 'di 2/6/2001 14:02'! borderWidthForRounding ^ self borderWidth! ! !Morph methodsFor: 'accessing' stamp: 'tk 2/15/2001 15:55'! color ^ color "has already been set to ((self valueOfProperty: #fillStyle) asColor)"! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/6/2001 09:03'! color: aColor "Set the receiver's color. Directly set the color if appropriate, else go by way of fillStyle" (aColor isColor or: [aColor isKindOf: InfiniteForm]) ifFalse:[^ self fillStyle: aColor]. color = aColor ifFalse: [self removeProperty: #fillStyle. color _ aColor. self changed]! ! !Morph methodsFor: 'accessing' stamp: 'ar 8/15/2001 22:40'! colorForInsets "Return the color to be used for shading inset borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned" (color isColor and:[color isTransparent and:[owner notNil]]) ifTrue:[^owner colorForInsets]. ^ color colorForInsets ! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/27/2001 17:56'! couldHaveRoundedCorners ^ true! ! !Morph methodsFor: 'accessing' stamp: 'nk 4/15/2004 07:50'! doesBevels "To return true means that this object can show bevelled borders, and therefore can accept, eg, #raised or #inset as valid borderColors. Must be overridden by subclasses that do not support bevelled borders." ^ false! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! eventHandler "answer the receiver's eventHandler" ^ self hasExtension ifTrue: [self extension eventHandler] ! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 19:25'! eventHandler: anEventHandler "Note that morphs can share eventHandlers and all is OK. " self assureExtension eventHandler: anEventHandler! ! !Morph methodsFor: 'accessing' stamp: 'sw 8/12/2001 17:29'! highlightOnlySubmorph: aMorph "Distinguish only aMorph with border highlighting (2-pixel wide red); make all my other submorphs have one-pixel-black highlighting. This is a rather special-purpose and hard-coded highlighting regime, of course. Later, if someone cared to do it, we could parameterize the widths and colors via properties, or some such." self submorphs do: [:m | m == aMorph ifTrue: [m borderWidth: 2; borderColor: Color red] ifFalse: [m borderWidth: 1; borderColor: Color black]]! ! !Morph methodsFor: 'accessing' stamp: 'tk 1/31/2002 10:25'! insetColor owner ifNil:[^self color]. ^ self colorForInsets! ! !Morph methodsFor: 'accessing' stamp: 'sw 6/13/2001 01:04'! isFlap "Answer whether the receiver claims to be a flap" ^ self hasProperty: #flap! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'! isLocked "answer whether the receiver is Locked" self hasExtension ifFalse: [^ false]. ^ self extension locked! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:37'! isSticky "answer whether the receiver is Sticky" self hasExtension ifFalse: [^ false]. ^ self extension sticky! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'! lock: aBoolean "change the receiver's lock property" (self hasExtension not and: [aBoolean not]) ifTrue: [^ self]. self assureExtension locked: aBoolean! ! !Morph methodsFor: 'accessing' stamp: 'sw 6/20/2001 15:45'! methodCommentAsBalloonHelp "Given that I am a morph that is associated with an object and a method, answer a suitable method comment relating to that object & method if possible" | inherentSelector actual | (inherentSelector _ self valueOfProperty: #inherentSelector) ifNotNil: [(actual _ (self ownerThatIsA: PhraseTileMorph orA: SyntaxMorph) actualObject) ifNotNil: [^ actual class precodeCommentOrInheritedCommentFor: inherentSelector]]. ^ nil! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42'! player "answer the receiver's player" ^ self hasExtension ifTrue: [self extension player]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53'! player: anObject "change the receiver's player" self assureExtension player: anObject! ! !Morph methodsFor: 'accessing' stamp: 'dgd 3/7/2003 15:24'! raisedColor "Return the color to be used for shading raised borders. The default is my own color, but it might want to be, eg, my owner's color. Whoever's color ends up prevailing, the color itself gets the last chance to determine, so that when, for example, an InfiniteForm serves as the color, callers won't choke on some non-Color object being returned" (color isColor and: [color isTransparent and: [owner notNil]]) ifTrue: [^ owner raisedColor]. ^ color asColor raisedColor! ]style[(11 2 355 3 5 18 5 26 5 24 5 18 5 20)f2b,f2,f2c146044000,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2,f2cmagenta;,f2! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'! resistsRemoval "Answer whether the receiver is marked as resisting removal" ^ self hasProperty: #resistsRemoval! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 16:33'! resistsRemoval: aBoolean "Set the receiver's resistsRemoval property as indicated" aBoolean ifTrue: [self setProperty: #resistsRemoval toValue: true] ifFalse: [self removeProperty: #resistsRemoval]! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/26/2001 16:16'! setBorderStyle: aSymbol "Set the border style of my costume" | aStyle | aStyle _ self borderStyleForSymbol: aSymbol. aStyle ifNil: [^ self]. (self canDrawBorder: aStyle) ifTrue: [self borderStyle: aStyle]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'! sticky: aBoolean "change the receiver's sticky property" self extension sticky: aBoolean! ! !Morph methodsFor: 'accessing' stamp: 'RAA 2/19/2001 17:38'! toggleLocked self lock: self isLocked not! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/15/2001 12:21'! toggleResistsRemoval "Toggle the resistsRemoval property" self resistsRemoval ifTrue: [self removeProperty: #resistsRemoval] ifFalse: [self setProperty: #resistsRemoval toValue: true]! ! !Morph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:40'! toggleStickiness "togle the receiver's Stickiness" self hasExtension ifFalse: [^ self beSticky]. self extension sticky: self extension sticky not! ! !Morph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'! wantsToBeCachedByHand "Return true if the receiver wants to be cached by the hand when it is dragged around. Note: The default implementation queries all submorphs since subclasses may have shapes that do not fill the receiver's bounds completely." self hasTranslucentColor ifTrue:[^false]. self submorphsDo:[:m| m wantsToBeCachedByHand ifFalse:[^false]. ]. ^true! ! !Morph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 16:21'! wantsToBeTopmost "Answer if the receiver want to be one of the topmost objects in its owner" ^ self isFlapOrTab! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:55'! assureExtension "creates an extension for the receiver if needed" self hasExtension ifFalse: [self initializeExtension]. ^ self extension! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22'! extension "answer the recevier's extension" ^ extension! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:55'! hasExtension "answer whether the receiver has extention" ^ self extension notNil! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57'! initializeExtension "private - initializes the receiver's extension" self privateExtension: MorphExtension new initialize! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57'! privateExtension: aMorphExtension "private - change the receiver's extension" extension _ aMorphExtension! ! !Morph methodsFor: 'accessing - extension' stamp: 'dgd 2/16/2003 19:57'! resetExtension "reset the extension slot if it is not needed" (self hasExtension and: [self extension isDefault]) ifTrue: [self privateExtension: nil] ! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:58'! hasProperty: aSymbol "Answer whether the receiver has the property named aSymbol" self hasExtension ifFalse: [^ false]. ^ self extension hasProperty: aSymbol! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:08'! otherProperties "answer the receiver's otherProperties" ^ self hasExtension ifTrue: [self extension otherProperties]! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:56'! removeProperty: aSymbol "removes the property named aSymbol if it exists" self hasExtension ifFalse: [^ self]. self extension removeProperty: aSymbol! ! !Morph methodsFor: 'accessing - properties' stamp: 'tk 10/9/2002 08:30'! setProperties: aList "Set many properties at once from a list of prop, value, prop, value" 1 to: aList size by: 2 do: [:ii | self setProperty: (aList at: ii) toValue: (aList at: ii+1)].! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 21:49'! setProperty: aSymbol toValue: anObject "change the receiver's property named aSymbol to anObject" anObject ifNil: [^ self removeProperty: aSymbol]. self assureExtension setProperty: aSymbol toValue: anObject! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 21:00'! valueOfProperty: aSymbol "answer the value of the receiver's property named aSymbol" ^ self hasExtension ifTrue: [self extension valueOfProperty: aSymbol]! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 21:00'! valueOfProperty: aSymbol ifAbsent: aBlock "if the receiver possesses a property of the given name, answer its value. If not then evaluate aBlock and answer the result of this block evaluation" ^ self hasExtension ifTrue: [self extension valueOfProperty: aSymbol ifAbsent: aBlock] ifFalse: [aBlock value]! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55'! valueOfProperty: aSymbol ifAbsentPut: aBlock "If the receiver possesses a property of the given name, answer its value. If not, then create a property of the given name, give it the value obtained by evaluating aBlock, then answer that value" ^ self assureExtension valueOfProperty: aSymbol ifAbsentPut: aBlock! ! !Morph methodsFor: 'accessing - properties' stamp: 'dgd 2/16/2003 20:55'! valueOfProperty: aSymbol ifPresentDo: aBlock "If the receiver has a property of the given name, evaluate aBlock on behalf of the value of that property" self hasExtension ifFalse: [^ self]. ^ aBlock value: (self extension valueOfProperty: aSymbol ifAbsent: [^ self])! ! !Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:09'! doButtonAction "If the receiver has a button-action defined, do it now. The default button action of any morph is, well, to do nothing. Note that there are several ways -- too many ways -- for morphs to have button-like actions. This one refers not to the #mouseUpCodeToRun feature, nor does it refer to the Player-scripting mechanism. Instead it is intended for morph classes whose very nature is to be buttons -- this method provides glue so that arbitrary buttons on the UI can be 'fired' programatticaly from user scripts"! ! !Morph methodsFor: 'button' stamp: 'sw 2/6/2001 23:22'! fire "If the receiver has any kind of button-action defined, fire that action now. Any morph can have special, personal mouseUpCodeToRun, and that will be triggered by this. Additionally, some morphs have specific buttonness, and these get sent the #doButtonAction message to carry out their firing. Finally, some morphs have mouse behaviors associated with one or more Player scripts. For the present, we'll try out doing *all* the firings this object can do. " self firedMouseUpCode. "This will run the mouseUpCodeToRun, if any" self player ifNotNil: [self player fireOnce]. "Run mouseDown and mouseUp scripts" self doButtonAction "Do my native button action, if any"! ! !Morph methodsFor: 'button' stamp: 'dgd 2/22/2003 14:31'! firedMouseUpCode "If the user has special mouseUpCodeToRun, then fire it once right now and return true, else return false" | evt | (self world isNil or: [self mouseUpCodeOrNil isNil]) ifTrue: [^false]. evt := MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand. self programmedMouseUp: evt for: self. ^true! ! !Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 14:45'! buttonProperties ^self valueOfProperty: #universalButtonProperties! ! !Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 14:45'! buttonProperties: propertiesOrNil propertiesOrNil ifNil: [ self removeProperty: #universalButtonProperties ] ifNotNil: [ self setProperty: #universalButtonProperties toValue: propertiesOrNil ].! ! !Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 07:49'! ensuredButtonProperties self hasButtonProperties ifFalse: [ self buttonProperties: (ButtonProperties new visibleMorph: self) ]. ^self buttonProperties! ! !Morph methodsFor: 'button properties' stamp: 'RAA 3/8/2001 07:18'! hasButtonProperties ^self hasProperty: #universalButtonProperties! ! !Morph methodsFor: 'caching' stamp: 'tak 1/12/2005 14:57'! releaseCachedState "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." self formerOwner: nil. self formerPosition: nil. self removeProperty: #undoGrabCommand. self wonderlandTexture: nil. "We can recreate it if needed" self borderStyle releaseCachedState. ! ! !Morph methodsFor: 'card in a stack' stamp: 'dgd 2/22/2003 14:26'! abstractAModel "Find data-containing fields in me. Make a new class, whose instance variables are named for my fields, and whose values are the values I am showing. Use a CardPlayer for now. Force the user to name the fields. Make slots for text, Number Watchers, SketchMorphs, and ImageMorphs." | instVarNames unnamed ans player twoListsOfMorphs holdsSepData docks oldPlayer iVarName | (oldPlayer := self player) ifNotNil: [oldPlayer belongsToUniClass ifTrue: ["Player" oldPlayer class instVarNames notEmpty ifTrue: [self inform: 'I already have a regular Player, so I can''t have a CardPlayer'. ^true]]]. twoListsOfMorphs := StackMorph discoverSlots: self. holdsSepData := twoListsOfMorphs first. instVarNames := ''. holdsSepData do: [:ea | iVarName := Utilities wellFormedInstanceVariableNameFrom: ea knownName. iVarName = ea knownName ifFalse: [ea name: iVarName]. instVarNames := instVarNames , iVarName , ' ']. unnamed := twoListsOfMorphs second. "have default names" instVarNames isEmpty ifTrue: [self inform: 'No named fields were found. Please get a halo on each field and give it a name. Labels or non-data fields should be named "shared xxx".'. ^false]. unnamed notEmpty ifTrue: [ans := PopUpMenu confirm: 'Data fields are ' , instVarNames printString , ('\Some fields are not named. Are they labels or non-data fields?' , '\Please get a halo on each data field and give it a name.') withCRs trueChoice: 'All other fields are non-data fields' falseChoice: 'Stop. Let me give a name to some more fields'. ans ifFalse: [^false]]. unnamed withIndexDo: [:mm :ind | mm setName: 'shared label ' , ind printString]. "Make a Player with instVarNames. Make me be the costume" player := CardPlayer instanceOfUniqueClassWithInstVarString: instVarNames andClassInstVarString: ''. self player: player. player costume: self. "Fill in the instance values. Make docks first." docks := OrderedCollection new. holdsSepData do: [:morph | morph setProperty: #shared toValue: true. "in case it is deeply embedded" morph setProperty: #holdsSeparateDataForEachInstance toValue: true. player class compileInstVarAccessorsFor: morph knownName. morph isSyntaxMorph ifTrue: [morph setTarget: player]. "hookup the UpdatingString!!" docks addAll: morph variableDocks]. player class newVariableDocks: docks. docks do: [:dd | dd storeMorphDataInInstance: player]. "oldPlayer class mdict do: [:assoc | move to player]. move methods to new class?" "oldPlayer become: player." ^true "success"! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:31'! beAStackBackground "Transform the receiver into one that has stack-background behavior. If just becoming a stack, allocate a uniclass to represent the cards (if one does not already exist" self assuredCardPlayer assureUniClass. self setProperty: #tabAmongFields toValue: true. self setProperty: #stackBackground toValue: true. "put my submorphs onto the background" submorphs do: [:mm | mm setProperty: #shared toValue: true]. self reassessBackgroundShape! ! !Morph methodsFor: 'card in a stack' stamp: 'sw 11/8/2002 14:57'! becomeSharedBackgroundField "Mark the receiver as holding separate data for each instance (i.e., like a 'background field') and reassess the shape of the corresponding background so that it will be able to accommodate this arrangement." ((self hasProperty: #shared) and: [self hasProperty: #holdsSeparateDataForEachInstance]) ifFalse: [self setProperty: #shared toValue: true. self setProperty: #holdsSeparateDataForEachInstance toValue: true. self stack reassessBackgroundShape]! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 18:54'! containsCard: aCard "Answer whether the given card belongs to the uniclass representing the receiver" ^ self isStackBackground and: [aCard isKindOf: self player class baseUniclass]! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:32'! currentDataInstance "Answer the current data instance" ^ self player! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:33'! explainDesignations "Hand the user an object that contains explanations for the designation feedback used" StackMorph designationsExplainer openInHand "self currentWorld explainDesignations"! ! !Morph methodsFor: 'card in a stack' stamp: 'yo 2/17/2005 17:47'! insertAsStackBackground "I am not yet in a stack. Find a Stack that my reference point (center) overlaps, and insert me as a new background." | aMorph | self isStackBackground ifTrue: [^ Beeper beep]. "already in a stack. Must clear flags when remove." " self potentialEmbeddingTargets do: [:mm | No, force user to choose a stack. (mm respondsTo: #insertAsBackground:resize:) ifTrue: [ ^ mm insertAsBackground: self resize: false]]. " "None found, ask user" self inform: 'Please click on a Stack' translated. Sensor waitNoButton. aMorph _ self world chooseClickTarget. aMorph ifNil: [^ self]. (aMorph ownerThatIsA: StackMorph) insertAsBackground: self resize: false.! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:35'! insertCard "Insert a new card in the stack, with the receiver as its background, and have it become the current card of the stack" self stackDo: [:aStack | aStack insertCardOfBackground: self]! ! !Morph methodsFor: 'card in a stack' stamp: 'sw 11/8/2002 15:16'! installAsCurrent: anInstance "Install anInstance as the one currently viewed in the receiver. Dock up all the morphs in the receiver which contain data rooted in the player instance to the instance data. Run any 'opening' scripts that pertain." | fieldList itsFocus | self player == anInstance ifTrue: [^ self]. fieldList _ self allMorphs select: [:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]]. self currentWorld hands do: [:aHand | (itsFocus _ aHand keyboardFocus) notNil ifTrue: [(fieldList includes: itsFocus) ifTrue: [aHand newKeyboardFocus: nil]]]. self player uninstallFrom: self. "out with the old" anInstance installPrivateMorphsInto: self. self changed. anInstance costume: self. self player: anInstance. self player class variableDocks do: [:aVariableDock | aVariableDock dockMorphUpToInstance: anInstance]. self currentWorld startSteppingSubmorphsOf: self! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:42'! isStackBackground "Answer whether the receiver serves as a background of a stack" ^ ((owner isKindOf: StackMorph) and: [owner currentPage == self]) or: [self hasProperty: #stackBackground] "This odd property-based check is because when a paste-up-morph is not the *current* background of a stack, it is maddeningly ownerlyess"! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:38'! makeHoldSeparateDataForEachInstance "Mark the receiver as holding separate data for each instance (i.e., like a 'background field') and reassess the shape of the corresponding background so that it will be able to accommodate this arrangement." self setProperty: #holdsSeparateDataForEachInstance toValue: true. self stack reassessBackgroundShape.! ! !Morph methodsFor: 'card in a stack' stamp: 'nb 6/17/2003 12:25'! newCard "Create a new card for the receiver and return it" | aNewInstance | self isStackBackground ifFalse: [^ Beeper beep]. "bulletproof against deconstruction" aNewInstance _ self player class baseUniclass new. ^ aNewInstance! ! !Morph methodsFor: 'card in a stack' stamp: 'md 10/22/2003 15:52'! reassessBackgroundShape "A change has been made which may affect the instance structure of the Card uniclass that holds the instance state, which can also be thought of as the 'card data'." "Caution: still to be done: the mechanism so that when a new instance variable is added, it gets initialized in all subinstances of the receiver's player, which are the cards of this shape. One needs to take into account here the instance variable names coming in; those that are unchanged should keep their values, but those that have newly arrived should obtain their default values from the morphs on whose behalf they are being maintained in the model" | takenNames uniqueName requestedName variableDocks docks sepDataMorphs sorted existing name1 name2 | self isStackBackground ifFalse: [^Beeper beep]. "bulletproof against deconstruction" Cursor wait showWhile: [variableDocks := OrderedCollection new. "This will be stored in the uniclass's class-side inst var #variableDocks" takenNames := OrderedCollection new. sepDataMorphs := OrderedCollection new. "fields, holders of per-card data" self submorphs do: [:aMorph | aMorph renderedMorph holdsSeparateDataForEachInstance ifTrue: [sepDataMorphs add: aMorph renderedMorph] ifFalse: ["look for buried fields, inside a frame" aMorph renderedMorph isShared ifTrue: [aMorph allMorphs do: [:mm | mm renderedMorph holdsSeparateDataForEachInstance ifTrue: [sepDataMorphs add: mm renderedMorph]]]]]. sorted := SortedCollection new sortBlock: [:a :b | (a valueOfProperty: #cardInstance) notNil]. "puts existing ones first" sorted addAll: sepDataMorphs. sorted do: [:aMorph | docks := aMorph variableDocks. "Each morph can request multiple variables. This complicates matters somewhat but creates a generality for Fabrk-like uses. Each spec is an instance of VariableDock, and it provides a point of departure for the negotiation between the PasteUp and its constitutent morphs" docks do: [:aVariableDock | uniqueName := self player uniqueInstanceVariableNameLike: (requestedName := aVariableDock variableName) excluding: takenNames. uniqueName ~= requestedName ifTrue: [aVariableDock variableName: uniqueName. aMorph noteNegotiatedName: uniqueName for: requestedName]. takenNames add: uniqueName]. variableDocks addAll: docks]. existing := self player class instVarNames. variableDocks := (variableDocks asSortedCollection: [:dock1 :dock2 | name1 := dock1 variableName. name2 := dock2 variableName. (existing indexOf: name1 ifAbsent: [0]) < (existing indexOf: name2 ifAbsent: [variableDocks size])]) asOrderedCollection. self player class setNewInstVarNames: (variableDocks collect: [:info | info variableName asString]). "NB: sets up accessors, and removes obsolete ones" self player class newVariableDocks: variableDocks]! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:46'! relaxGripOnVariableNames "Abandon any memory of specific variable names that should be preserved. The overall situation here is not yet completely understood, and this relaxation is basically always done on each reassessment of the background shape nowadays. But this doesn't feel quite right, because if the user has somehow intervened to specify certain name preference we should perhaps honored it. Or perhaps that is no longer relevant. ????" self submorphs do: [:m | m removeProperty: #variableName. m removeProperty: #setterSelector]. self reassessBackgroundShape ! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:47'! reshapeBackground "Abandon any memory of variable-name preferences, and reassess the shape of the background" self relaxGripOnVariableNames. "self reassessBackgroundShape. already done there"! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:48'! showBackgroundObjects "Momentarily highlight just the background objects on the current playfield" self isStackBackground ifFalse: [^ self]. self invalidRect: self bounds. self currentWorld doOneCycle. Display restoreAfter: [self submorphsDo: [:aMorph | (aMorph renderedMorph hasProperty: #shared) ifTrue: [Display border: (aMorph fullBoundsInWorld insetBy: -6) width: 6 rule: Form over fillColor: Color blue]]]! ! !Morph methodsFor: 'card in a stack' stamp: 'aoy 2/15/2003 21:50'! showDesignationsOfObjects "Momentarily show the designations of objects on the receiver" | colorToUse aLabel | self isStackBackground ifFalse: [^self]. self submorphsDo: [:aMorph | aLabel :=aMorph renderedMorph holdsSeparateDataForEachInstance ifTrue: [colorToUse := Color orange. aMorph externalName] ifFalse: [colorToUse := aMorph isShared ifFalse: [Color red] ifTrue: [Color green]. nil]. Display border: (aMorph fullBoundsInWorld insetBy: -6) width: 6 rule: Form over fillColor: colorToUse. aLabel ifNotNil: [aLabel asString displayOn: Display at: aMorph fullBoundsInWorld bottomLeft + (0 @ 5) textColor: Color blue]]. Sensor anyButtonPressed ifTrue: [Sensor waitNoButton] ifFalse: [Sensor waitButton]. World fullRepaintNeeded! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 10/30/2001 13:50'! showForegroundObjects "Temporarily highlight the foreground objects" self isStackBackground ifFalse: [^ self]. Display restoreAfter: [self submorphsDo: [:aMorph | aMorph renderedMorph isShared ifFalse: [Display border: (aMorph fullBoundsInWorld insetBy: -6) width: 6 rule: Form over fillColor: Color orange]]]! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:53'! stack "Answer the nearest containing Stack, or, if none, a stack in the current project, and if still none, nil. The extra messiness is because uninstalled backgrounds don't have an owner pointers to their stack." | aStack bkgnd | bkgnd _ self orOwnerSuchThat: [:oo | oo hasProperty: #myStack]. bkgnd ifNotNil: [^ bkgnd valueOfProperty: #myStack]. "fallbacks" (aStack _ self ownerThatIsA: StackMorph) ifNotNil: [^ aStack]. ^ Project current currentStack! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 11/2/2001 13:38'! stopHoldingSeparateDataForEachInstance "Make the receiver no longer hold separate data for each instance" self removeProperty: #holdsSeparateDataForEachInstance. self stack reassessBackgroundShape.! ! !Morph methodsFor: 'card in a stack' stamp: 'dgd 8/28/2004 13:56'! tabHitWithEvent: anEvent "The tab key was hit. The keyboard focus has referred this event to me, though this perhaps seems rather backwards. Anyway, the assumption is that I have the property #tabAmongFields, so now the task is to tab to the next field." | currentFocus fieldList anIndex itemToHighlight variableBearingMorphs otherAmenableMorphs | currentFocus _ anEvent hand keyboardFocus. fieldList _ self allMorphs select: [:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]]. variableBearingMorphs _ self player isNil ifTrue:[#()] ifFalse:[self player class variableDocks collect: [:vd | vd definingMorph] thenSelect: [:m | m isInWorld]]. otherAmenableMorphs _ (self allMorphs select: [:aMorph | (aMorph wouldAcceptKeyboardFocusUponTab) and: [aMorph isLocked not]]) copyWithoutAll: variableBearingMorphs. fieldList _ variableBearingMorphs, otherAmenableMorphs. anIndex _ fieldList indexOf: currentFocus ifAbsent: [nil]. itemToHighlight _ fieldList atWrap: (anIndex ifNotNil: [anEvent shiftPressed ifTrue: [anIndex - 1] ifFalse: [anIndex + 1]] ifNil: [1]). anEvent hand newKeyboardFocus: itemToHighlight. self flag: #arNote. "really???" itemToHighlight editor selectAll. itemToHighlight invalidRect: itemToHighlight bounds ! ! !Morph methodsFor: 'card in a stack' stamp: 'tk 11/4/2001 20:57'! wrapWithAStack "Install me as a card inside a new stack. The stack has no border or controls, so I my look is unchanged. If I don't already have a CardPlayer, find my data fields and make one. Be ready to make new cards in the stack that look like me, but hold different field data." self player class officialClass == CardPlayer ifFalse: [ self abstractAModel ifFalse: [^ false]]. StackMorph new initializeWith: self. self stack addHalo. "Makes it easier for the user"! ! !Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 21:50'! addedMorph: aMorph "Notify the receiver that the given morph was just added." ! ! !Morph methodsFor: 'change reporting' stamp: 'md 12/12/2003 17:01'! addedOrRemovedSubmorph: aMorph self deprecated:'Use #privateInvalidateMorph: instead'. ^self privateInvalidateMorph: aMorph "which is the equvivalent here"! ! !Morph methodsFor: 'change reporting' stamp: 'nk 9/24/2003 10:01'! invalidRect: aRectangle from: aMorph | damageRect | aRectangle hasPositiveExtent ifFalse: [ ^self ]. damageRect _ aRectangle. aMorph == self ifFalse:[ "Clip to receiver's clipping bounds if the damage came from a child" self clipSubmorphs ifTrue:[damageRect _ aRectangle intersect: self clippingBounds]]. owner ifNotNil: [owner invalidRect: damageRect from: self]. self wonderlandTexture ifNotNil:[self isValidWonderlandTexture: false]. ! ! !Morph methodsFor: 'change reporting' stamp: 'ar 8/12/2003 22:26'! privateInvalidateMorph: aMorph "Private. Invalidate the given morph after adding or removing. This method is private because a) we're invalidating the morph 'remotely' and b) it forces a fullBounds computation which should not be necessary for a general morph c) the morph may or may not actually invalidate anything (if it's not in the world nothing will happen) and d) the entire mechanism should be rewritten." aMorph fullBounds. aMorph changed! ! !Morph methodsFor: 'change reporting' stamp: 'tk 8/24/2001 22:07'! userSelectedColor: aColor "The user, via the UI, chose aColor to be the color for the receiver; set it, and tell my owner in case he wishes to react" self color: aColor. self world ifNotNil: [owner colorChangedForSubmorph: self]! ! !Morph methodsFor: 'classification' stamp: 'sw 2/26/2002 23:29'! demandsBoolean "Answer whether the receiver will only accept a drop if it is boolean-valued. Particular to tile-scripting." ^ self hasProperty: #demandsBoolean! ! !Morph methodsFor: 'classification' stamp: 'ar 6/30/2001 13:13'! isStandardViewer ^false! ! !Morph methodsFor: 'classification' stamp: 'ar 12/16/2001 18:28'! isTextMorph ^false! ! !Morph methodsFor: 'copying' stamp: 'tk 2/19/2001 18:21'! copy ^ self veryDeepCopy! ! !Morph methodsFor: 'copying' stamp: 'tk 2/14/2001 12:47'! deepCopy self error: 'Please use veryDeepCopy'. ! ! !Morph methodsFor: 'copying' stamp: 'sw 10/17/2001 10:06'! duplicate "Make and return a duplicate of the receiver" | newMorph aName w aPlayer | self okayToDuplicate ifFalse: [^ self]. aName _ (w _ self world) ifNotNil: [w nameForCopyIfAlreadyNamed: self]. newMorph _ self veryDeepCopy. aName ifNotNil: [newMorph setNameTo: aName]. newMorph arrangeToStartStepping. newMorph privateOwner: nil. "no longer in world" newMorph isPartsDonor: false. "no longer parts donor" (aPlayer _ newMorph player) belongsToUniClass ifTrue: [aPlayer class bringScriptsUpToDate]. ^ newMorph! ! !Morph methodsFor: 'copying' stamp: 'nk 3/12/2001 17:07'! duplicateMorphCollection: aCollection "Make and return a duplicate of the receiver" | newCollection names | names _ aCollection collect: [ :ea | | newMorph w | (w _ ea world) ifNotNil: [w nameForCopyIfAlreadyNamed: ea]. ]. newCollection _ aCollection veryDeepCopy. newCollection with: names do: [ :newMorph :name | name ifNotNil: [ newMorph setNameTo: name ]. newMorph arrangeToStartStepping. newMorph privateOwner: nil. "no longer in world" newMorph isPartsDonor: false. "no longer parts donor" ]. ^newCollection! ! !Morph methodsFor: 'copying' stamp: 'sw 2/16/2001 16:30'! fullCopy "Deprecated, but maintained for backward compatibility with existing code (no senders in the base 3.0 image). Calls are revectored to #veryDeepCopy, but note that #veryDeepCopy does not do exactly the same thing that the original #fullCopy did, so beware!!" ^ self veryDeepCopy! ! !Morph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:53'! updateReferencesUsing: aDictionary "Update intra-morph references within a composite morph that has been copied. For example, if a button refers to morph X in the orginal composite then the copy of that button in the new composite should refer to the copy of X in new composite, not the original X. This default implementation updates the contents of any morph-bearing slot. It may be overridden to avoid this behavior if so desired." | old | Morph instSize + 1 to: self class instSize do: [:i | old _ self instVarAt: i. old isMorph ifTrue: [self instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]. self hasExtension ifTrue: [self extension updateReferencesUsing: aDictionary]! ! !Morph methodsFor: 'copying' stamp: 'nk 10/11/2003 16:59'! usableSiblingInstance "Return another similar morph whose Player is of the same class as mine. Do not open it in the world." | aName usedNames newPlayer newMorph topRenderer | (topRenderer := self topRendererOrSelf) == self ifFalse: [^topRenderer usableSiblingInstance]. self assuredPlayer assureUniClass. newMorph := self veryDeepCopySibling. newPlayer := newMorph player. newPlayer resetCostumeList. (aName := self knownName) isNil ifTrue: [self player notNil ifTrue: [aName := newMorph innocuousName]]. "Force a difference here" aName notNil ifTrue: [usedNames := (self world ifNil: [OrderedCollection new] ifNotNil: [self world allKnownNames]) copyWith: aName. newMorph setNameTo: (Utilities keyLike: aName satisfying: [:f | (usedNames includes: f) not])]. newMorph privateOwner: nil. newPlayer assureEventHandlerRepresentsStatus. self presenter flushPlayerListCache. ^newMorph! ! !Morph methodsFor: 'copying' stamp: 'tk 2/3/2001 14:29'! veryDeepFixupWith: deepCopier "If some fields were weakly copied, fix new copy here." "super veryDeepFixupWith: deepCopier. Object has no fixups, so don't call it" "If my owner is being duplicated too, then store his duplicate. If I am owned outside the duplicated tree, then I am no longer owned!!" owner _ deepCopier references at: owner ifAbsent: [nil]. ! ! !Morph methodsFor: 'copying' stamp: 'dgd 2/16/2003 19:59'! veryDeepInner: deepCopier "The inner loop, so it can be overridden when a field should not be traced." "super veryDeepInner: deepCopier. know Object has no inst vars" bounds _ bounds clone. "Points are shared with original" "owner _ owner. special, see veryDeepFixupWith:" submorphs _ submorphs veryDeepCopyWith: deepCopier. "each submorph's fixup will install me as the owner" "fullBounds _ fullBounds. fullBounds is shared with original!!" color _ color veryDeepCopyWith: deepCopier. "color, if simple, will return self. may be complex" self privateExtension: (self extension veryDeepCopyWith: deepCopier)! ! !Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:36'! addDebuggingItemsTo: aMenu hand: aHandMorph aMenu add: 'debug...' translated subMenu: (self buildDebugMenu: aHandMorph)! ! !Morph methodsFor: 'debug and other' stamp: 'gm 4/25/2004 14:23'! addMouseUpAction | codeToRun oldCode | oldCode := self valueOfProperty: #mouseUpCodeToRun ifAbsent: ['']. codeToRun := FillInTheBlank request: 'MouseUp expression:' translated initialAnswer: oldCode. self addMouseUpActionWith: codeToRun! ! !Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'! addMouseUpActionWith: codeToRun ((codeToRun isMessageSend) not and: [codeToRun isEmptyOrNil]) ifTrue: [^self]. self setProperty: #mouseUpCodeToRun toValue: codeToRun. self on: #mouseUp send: #programmedMouseUp:for: to: self. self on: #mouseDown send: #programmedMouseDown:for: to: self. self on: #mouseEnter send: #programmedMouseEnter:for: to: self. self on: #mouseLeave send: #programmedMouseLeave:for: to: self! ! !Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 14:27'! allStringsAfter: aSubmorph "return an OrderedCollection of strings of text in my submorphs. If aSubmorph is non-nil, begin with that container." | list string ok | list := OrderedCollection new. ok := aSubmorph isNil. self allMorphsDo: [:sub | ok ifFalse: [ok := sub == aSubmorph]. "and do this one too" ok ifTrue: [(string := sub userString) ifNotNil: [string isString ifTrue: [list add: string] ifFalse: [list addAll: string]]]]. ^list! ! !Morph methodsFor: 'debug and other' stamp: 'nk 6/14/2004 16:14'! buildDebugMenu: aHand "Answer a debugging menu for the receiver. The hand argument is seemingly historical and plays no role presently" | aMenu aPlayer | aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. (self hasProperty: #errorOnDraw) ifTrue: [aMenu add: 'start drawing again' translated action: #resumeAfterDrawError. aMenu addLine]. (self hasProperty: #errorOnStep) ifTrue: [aMenu add: 'start stepping again' translated action: #resumeAfterStepError. aMenu addLine]. aMenu add: 'inspect morph' translated action: #inspectInMorphic:. aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain. Smalltalk isMorphic ifFalse: [aMenu add: 'inspect morph (in MVC)' translated action: #inspect]. self isMorphicModel ifTrue: [aMenu add: 'inspect model' translated target: self model action: #inspect]. (aPlayer _ self player) ifNotNil: [aMenu add: 'inspect player' translated target: aPlayer action: #inspect]. aMenu add: 'explore morph' translated target: self selector: #explore. aMenu addLine. aPlayer ifNotNil: [ aMenu add: 'viewer for Player' translated target: self player action: #beViewed. aMenu balloonTextForLastItem: 'Opens a viewer on my Player -- this is the same thing you get if you click on the cyan "View" halo handle' translated ]. aMenu add: 'viewer for Morph' translated target: self action: #viewMorphDirectly. aMenu balloonTextForLastItem: 'Opens a Viewer on this Morph, rather than on its Player' translated. aMenu addLine. aPlayer ifNotNil: [aPlayer class isUniClass ifTrue: [ aMenu add: 'browse player class' translated target: aPlayer action: #browseHierarchy]]. aMenu add: 'browse morph class' translated target: self selector: #browseHierarchy. (self isMorphicModel) ifTrue: [aMenu add: 'browse model class' target: self model selector: #browseHierarchy]. aMenu addLine. aPlayer ifNotNil: [aMenu add: 'player protocol (tiles)' translated target: aPlayer action: #openInstanceBrowserWithTiles "#browseProtocolForPlayer"]. aMenu add: 'morph protocol (text)' translated target: self selector: #haveFullProtocolBrowsed. aMenu add: 'morph protocol (tiles)' translated target: self selector: #openInstanceBrowserWithTiles. aMenu addLine. self addViewingItemsTo: aMenu. aMenu add: 'make own subclass' translated action: #subclassMorph; add: 'internal name ' translated action: #choosePartName; add: 'save morph in file' translated action: #saveOnFile; addLine; add: 'call #tempCommand' translated action: #tempCommand; add: 'define #tempCommand' translated action: #defineTempCommand; addLine; add: 'control-menu...' translated target: self selector: #invokeMetaMenu:; add: 'edit balloon help' translated action: #editBalloonHelpText. ^ aMenu! ! !Morph methodsFor: 'debug and other' stamp: 'sw 7/17/2001 19:08'! handMeTilesToFire "Construct a phrase of tiles comprising a line of code that will 'fire' this object, and hand it to the user" ActiveHand attachMorph: (self assuredPlayer tilesToCall: MethodInterface firingInterface)! ! !Morph methodsFor: 'debug and other' stamp: 'sw 2/6/2001 22:35'! mouseUpCodeOrNil "If the receiver has a mouseUpCodeToRun, return it, else return nil" ^ self valueOfProperty: #mouseUpCodeToRun ifAbsent: [nil]! ! !Morph methodsFor: 'debug and other' stamp: 'dgd 2/22/2003 19:05'! ownerChain "Answer a list of objects representing the receiver and all of its owners. The first element is the receiver, and the last one is typically the world in which the receiver resides" | c next | c := OrderedCollection with: self. next := self. [(next := next owner) notNil] whileTrue: [c add: next]. ^c asArray! ! !Morph methodsFor: 'debug and other' stamp: 'gm 2/22/2003 13:41'! programmedMouseUp: anEvent for: aMorph | aCodeString | self deleteAnyMouseActionIndicators. aCodeString := self valueOfProperty: #mouseUpCodeToRun ifAbsent: [^self]. (self fullBounds containsPoint: anEvent cursorPoint) ifFalse: [^self]. [(aCodeString isMessageSend) ifTrue: [aCodeString value] ifFalse: [Compiler evaluate: aCodeString for: self notifying: nil logged: false]] on: ProgressTargetRequestNotification do: [:ex | ex resume: self] "in case a save/load progress display needs a home"! ! !Morph methodsFor: 'debug and other' stamp: 'dgd 8/30/2003 20:43'! tempCommand "Generic backstop. If you care to, you can comment out what's below here, and substitute your own code, though the intention of design of the feature is that you leave this method as it is, and instead reimplement tempCommand in the class of whatever individual morph you care to. In any case, once you have your own #tempCommand in place, you will then be able to invoke it from the standard debugging menus." self inform: 'Before calling tempCommand, you should first give it a definition. To do this, choose "define tempCommand" from the debug menu.' translated! ! !Morph methodsFor: 'debug and other' stamp: 'sw 8/4/2001 00:33'! viewMorphDirectly "Open a Viewer directly on the Receiver, i.e. no Player involved" self presenter viewObjectDirectly: self renderedMorph ! ! !Morph methodsFor: 'dispatching' stamp: 'nk 2/15/2004 09:16'! disableSubmorphFocusForHand: aHandMorph "Check whether this morph or any of its submorph has the Genie focus. If yes, disable it." ! ! !Morph methodsFor: 'drawing' stamp: 'di 2/15/2001 14:51'! boundsWithinCorners ^ CornerRounder rectWithinCornersOf: self bounds! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02'! clipLayoutCells "Drawing/layout specific. If this property is set, clip the submorphs of the receiver by its cell bounds." ^ self valueOfProperty: #clipLayoutCells ifAbsent: [false]! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:02'! clipSubmorphs "Drawing specific. If this property is set, clip the receiver's submorphs to the receiver's clipping bounds." ^ self valueOfProperty: #clipSubmorphs ifAbsent: [false]! ! !Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 19:17'! drawDropShadowOn: aCanvas aCanvas translateBy: self shadowOffset during: [ :shadowCanvas | shadowCanvas shadowColor: self shadowColor. shadowCanvas roundCornersOf: self during: [ (shadowCanvas isVisible: self bounds) ifTrue:[shadowCanvas drawMorph: self ]] ]. ! ! !Morph methodsFor: 'drawing' stamp: 'ar 8/25/2001 17:31'! drawOn: aCanvas aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle. ! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:31'! drawSubmorphsOn: aCanvas "Display submorphs back to front" | drawBlock | submorphs isEmpty ifTrue: [^self]. drawBlock := [:canvas | submorphs reverseDo: [:m | canvas fullDrawMorph: m]]. self clipSubmorphs ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock] ifFalse: [drawBlock value: aCanvas]! ! !Morph methodsFor: 'drawing' stamp: 'sw 11/26/2003 17:43'! flashBounds "Flash the receiver's bounds -- does not use the receiver's color, thus works with StringMorphs and SketchMorphs, etc., for which #flash is useless. No senders initially, but useful to send this from a debugger or inspector" 5 timesRepeat: [Display flash: self boundsInWorld andWait: 120]! ! !Morph methodsFor: 'drawing' stamp: 'ar 12/30/2001 15:22'! fullDrawOn: aCanvas "Draw the full Morphic structure on the given Canvas" self visible ifFalse: [^ self]. (aCanvas isVisible: self fullBounds) ifFalse:[^self]. (self hasProperty: #errorOnDraw) ifTrue:[^self drawErrorOn: aCanvas]. "Note: At some point we should generalize this into some sort of multi-canvas so that we can cross-optimize some drawing operations." "Pass 1: Draw eventual drop-shadow" self hasDropShadow ifTrue: [self drawDropShadowOn: aCanvas]. (self hasRolloverBorder and: [(aCanvas seesNothingOutside: self bounds) not]) ifTrue: [self drawRolloverBorderOn: aCanvas]. "Pass 2: Draw receiver itself" aCanvas roundCornersOf: self during:[ (aCanvas isVisible: self bounds) ifTrue:[aCanvas drawMorph: self]. self drawSubmorphsOn: aCanvas. self drawDropHighlightOn: aCanvas. self drawMouseDownHighlightOn: aCanvas].! ! !Morph methodsFor: 'drawing' stamp: 'dgd 8/30/2003 20:20'! hasClipSubmorphsString "Answer a string that represents the clip-submophs checkbox" ^ (self clipSubmorphs ifTrue: ['<on>'] ifFalse: ['<off>']) , 'provide clipping' translated! ! !Morph methodsFor: 'drawing' stamp: 'ar 3/17/2001 15:56'! highlightForMouseDown: aBoolean aBoolean ifTrue:[self setProperty: #highlightedForMouseDown toValue: aBoolean] ifFalse:[self removeProperty: #highlightedForMouseDown. self resetExtension]. self changed! ! !Morph methodsFor: 'drawing' stamp: 'nk 9/1/2004 15:08'! imageForm: depth backgroundColor: aColor forRectangle: rect | canvas | canvas _ Display defaultCanvasClass extent: rect extent depth: depth. canvas translateBy: rect topLeft negated during:[:tempCanvas| tempCanvas fillRectangle: rect color: aColor. tempCanvas fullDrawMorph: self]. ^ canvas form offset: rect topLeft! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 21:41'! visible "answer whether the receiver is visible" self hasExtension ifFalse: [^ true]. ^ self extension visible! ! !Morph methodsFor: 'drawing' stamp: 'dgd 2/16/2003 20:24'! visible: aBoolean "set the 'visible' attribute of the receiver to aBoolean" (self hasExtension not and:[aBoolean]) ifTrue: [^ self]. self visible == aBoolean ifTrue: [^ self]. self assureExtension visible: aBoolean. self changed! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:48'! addDropShadowMenuItems: aMenu hand: aHand | menu | menu _ MenuMorph new defaultTarget: self. menu addUpdating: #hasDropShadowString action: #toggleDropShadow. menu addLine. menu add: 'shadow color...' translated target: self selector: #changeShadowColor. menu add: 'shadow offset...' translated target: self selector: #setShadowOffset:. aMenu add: 'drop shadow' translated subMenu: menu.! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:42'! hasDropShadow "answer whether the receiver has DropShadow" ^ self valueOfProperty: #hasDropShadow ifAbsent: [false]! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 8/30/2003 16:49'! hasDropShadowString ^ (self hasDropShadow ifTrue: ['<on>'] ifFalse: ['<off>']) , 'show shadow' translated! ! !Morph methodsFor: 'drop shadows' stamp: 'dgd 2/16/2003 21:58'! hasRolloverBorder "answer whether the receiver has RolloverBorder" ^ self valueOfProperty: #hasRolloverBorder ifAbsent: [false]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'! formerOwner: aMorphOrNil aMorphOrNil isNil ifTrue: [self removeProperty: #formerOwner] ifFalse: [self setProperty: #formerOwner toValue: aMorphOrNil]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 2/22/2003 14:31'! formerPosition: formerPosition formerPosition isNil ifTrue: [self removeProperty: #formerPosition] ifFalse: [self setProperty: #formerPosition toValue: formerPosition]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 6/13/2001 19:42'! justDroppedInto: aMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on -- and been accepted by -- a drop-sensitive morph" | aWindow partsBinCase cmd aStack | self formerOwner: nil. self formerPosition: nil. cmd _ self valueOfProperty: #undoGrabCommand. cmd ifNotNil:[aMorph rememberCommand: cmd. self removeProperty: #undoGrabCommand]. (partsBinCase _ aMorph isPartsBin) ifFalse: [self isPartsDonor: false]. (aWindow _ aMorph ownerThatIsA: SystemWindow) ifNotNil: [aWindow isActive ifFalse: [aWindow activate]]. (self isInWorld and: [partsBinCase not]) ifTrue: [self world startSteppingSubmorphsOf: self]. "Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage." "An object launched by certain parts-launcher mechanisms should end up fully visible..." (self hasProperty: #beFullyVisibleAfterDrop) ifTrue: [aMorph == ActiveWorld ifTrue: [self goHome]. self removeProperty: #beFullyVisibleAfterDrop]. (self holdsSeparateDataForEachInstance and: [(aStack _ self stack) notNil]) ifTrue: [aStack reassessBackgroundShape] ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 2/6/2001 22:12'! justGrabbedFrom: formerOwner "The receiver was just grabbed from its former owner and is now attached to the hand. By default, we pass this message on if we're a renderer." (self isRenderer and:[self hasSubmorphs]) ifTrue:[self firstSubmorph justGrabbedFrom: formerOwner].! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 3/27/2001 11:52'! nameForUndoWording "Return wording appropriate to the receiver for use in an undo-related menu item (and perhaps elsewhere)" | aName | aName _ self knownName ifNil: [self renderedMorph class name]. ^ aName truncateTo: 24! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 8/12/2003 23:35'! slideBackToFormerSituation: evt | slideForm formerOwner formerPosition aWorld startPoint endPoint trans | formerOwner := self formerOwner. formerPosition := self formerPosition. aWorld := evt hand world. trans := formerOwner transformFromWorld. slideForm := trans isPureTranslation ifTrue: [self imageForm offset: 0 @ 0] ifFalse: [((TransformationMorph new asFlexOf: self) transform: trans) imageForm offset: 0 @ 0]. startPoint := evt hand fullBounds origin. endPoint := trans localPointToGlobal: formerPosition. owner removeMorph: self. aWorld displayWorld. slideForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15. formerOwner addMorph: self. self position: formerPosition. self justDroppedInto: formerOwner event: evt! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'dgd 8/26/2003 21:44'! undoGrabCommand "Return an undo command for grabbing the receiver" | cmd | owner ifNil: [^ nil]. "no owner - no undo" ^ (cmd _ Command new) cmdWording: 'move ' translated, self nameForUndoWording; undoTarget: self selector: #undoMove:redo:owner:bounds:predecessor: arguments: {cmd. false. owner. self bounds. (owner morphPreceding: self)}; yourself! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 5/17/2001 12:47'! adoptVocabulary: aVocabulary "Make aVocabulary be the one used by me and my submorphs" self submorphsDo: [:m | m adoptVocabulary: aVocabulary]! ! !Morph methodsFor: 'e-toy support' stamp: 'yo 1/9/2004 16:10'! allMorphsAndBookPagesInto: aSet "Return a set of all submorphs. Don't forget the hidden ones like BookMorph pages that are not showing. Consider only objects that are in memory (see allNonSubmorphMorphs)." submorphs do: [:m | m allMorphsAndBookPagesInto: aSet]. self allNonSubmorphMorphs do: [:m | (aSet includes: m) ifFalse: ["Stop infinite recursion" m allMorphsAndBookPagesInto: aSet]]. aSet add: self. self player ifNotNil: [self player allScriptEditors do: [:e | e allMorphsAndBookPagesInto: aSet]]. ^ aSet! ! !Morph methodsFor: 'e-toy support' stamp: 'nk 1/6/2004 12:37'! asWearableCostume "Return a wearable costume for some player" ^(World drawingClass withForm: self imageForm) copyCostumeStateFrom: self! ! !Morph methodsFor: 'e-toy support' stamp: 'mir 6/13/2001 14:34'! asWearableCostumeOfExtent: extent "Return a wearable costume for some player" ^self asWearableCostume! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 5/18/2001 11:17'! changeAllBorderColorsFrom: oldColor to: newColor "Set any occurrence of oldColor as a border color in my entire submorph tree to be newColor" (self allMorphs select: [:m | m respondsTo: #borderColor:]) do: [:aMorph | aMorph borderColor = oldColor ifTrue: [aMorph borderColor: newColor]]! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 2/6/2001 04:21'! containingWindow "Answer a window or window-with-mvc that contains the receiver" ^ self ownerThatIsA: SystemWindow orA: MVCWiWPasteUpMorph! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:44'! decimalPlacesForGetter: aGetter "Answer the decimal places I prefer for showing a slot with the given getter, or nil if none" | decimalPrefs | decimalPrefs _ self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsent: [^ nil]. ^ decimalPrefs at: aGetter ifAbsent: [nil]! ! !Morph methodsFor: 'e-toy support' stamp: 'nb 6/17/2003 12:25'! definePath | points lastPoint aForm offset currentPoint dwell ownerPosition | points _ OrderedCollection new: 70. lastPoint _ nil. aForm _ self imageForm. offset _ aForm extent // 2. ownerPosition _ owner position. Cursor move show. Sensor waitButton. [Sensor anyButtonPressed and: [points size < 100]] whileTrue: [currentPoint _ Sensor cursorPoint. dwell _ 0. currentPoint = lastPoint ifTrue: [dwell _ dwell + 1. ((dwell \\ 1000) = 0) ifTrue: [Beeper beep]] ifFalse: [self position: (currentPoint - offset). self world displayWorld. (Delay forMilliseconds: 20) wait. points add: currentPoint. lastPoint _ currentPoint]]. points size > 1 ifFalse: [self inform: 'no path obtained'] ifTrue: [points size = 100 ifTrue: [self playSoundNamed: 'croak']. Transcript cr; show: 'path defined with ', points size printString, ' points'. self renderedMorph setProperty: #pathPoints toValue: (points collect: [:p | p - ownerPosition])]. Cursor normal show ! ! !Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:31'! enclosingEditor "Return the next editor around the receiver" | tested | tested := owner. [tested isNil] whileFalse: [tested isTileEditor ifTrue: [^tested]. tested := tested owner]. ^nil! ! !Morph methodsFor: 'e-toy support' stamp: 'nb 6/17/2003 12:25'! followPath | pathPoints offset | (pathPoints _ self renderedMorph valueOfProperty: #pathPoints) ifNil: [^ Beeper beep]. offset _ owner position - (self extent // 2). pathPoints do: [:aPoint | self position: aPoint + offset. self world displayWorld. (Delay forMilliseconds: 20) wait]! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 2/18/2003 02:54'! getCharacters "obtain a string value from the receiver. The default generic response is simply the name of the object." ^ self externalName! ! !Morph methodsFor: 'e-toy support' stamp: 'kfr 9/4/2004 15:22'! gridFormOrigin: origin grid: smallGrid background: backColor line: lineColor | bigGrid gridForm gridOrigin | gridOrigin _ origin \\ smallGrid. bigGrid _ (smallGrid asPoint x) @ (smallGrid asPoint y). gridForm _ Form extent: bigGrid depth: Display depth. backColor ifNotNil: [gridForm fillWithColor: backColor]. gridOrigin x to: gridForm width by: smallGrid x do: [:x | gridForm fill: (x@0 extent: 1@gridForm height) fillColor: lineColor]. gridOrigin y to: gridForm height by: smallGrid y do: [:y | gridForm fill: (0@y extent: gridForm width@1) fillColor: lineColor]. ^ InfiniteForm with: gridForm ! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 7/28/2004 16:05'! handUserASibling "Make and hand the user a sibling instance. Force the creation of a uniclass at this point if one does not already exist for the receiver." | topRend | topRend _ self topRendererOrSelf. topRend assuredPlayer assureUniClass. (topRend makeSiblings: 1) first openInHand! ! !Morph methodsFor: 'e-toy support' stamp: 'ar 2/7/2001 17:58'! isTileEditor "No, I'm not" ^false! ! !Morph methodsFor: 'e-toy support' stamp: 'dgd 9/6/2003 18:10'! makeGraphPaper | smallGrid backColor lineColor | smallGrid _ Compiler evaluate: (FillInTheBlank request: 'Enter grid size' translated initialAnswer: '16'). smallGrid ifNil: [^ self]. Utilities informUser: 'Choose a background color' translated during: [backColor _ Color fromUser]. Utilities informUser: 'Choose a line color' translated during: [lineColor _ Color fromUser]. self makeGraphPaperGrid: smallGrid background: backColor line: lineColor.! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 9/13/2002 17:45'! noteDecimalPlaces: aNumber forGetter: aGetter "Make a mental note of the user's preference for a particular number of decimal places to be associated with the slot with the given getter" (self renderedMorph valueOfProperty: #decimalPlacePreferences ifAbsentPut: [IdentityDictionary new]) at: aGetter put: aNumber! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 8/31/2004 14:11'! pinkXButton "Answer a button with the old X on a pink background, targeted to self" | aButton | aButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #PinkX). aButton color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonUp. aButton target: self. ^ aButton! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 9/11/2004 16:23'! referencePlayfield "Answer the PasteUpMorph to be used for cartesian-coordinate reference" | former | owner ifNotNil: [(self topRendererOrSelf owner isHandMorph and: [(former _ self formerOwner) notNil]) ifTrue: [former _ former renderedMorph. ^ former isPlayfieldLike ifTrue: [former] ifFalse: [former referencePlayfield]]]. self allOwnersDo: [:o | o isPlayfieldLike ifTrue: [^ o]]. ^ ActiveWorld! ! !Morph methodsFor: 'e-toy support' stamp: 'RAA 3/9/2001 14:37'! setAsActionInButtonProperties: buttonProperties ^false "means I don't know how to be set as a button action"! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 8/31/2004 14:06'! tanOButton "Answer a button with the old O on a tan background, targeted to self" | aButton | aButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #TanO). aButton color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonUp. aButton target: self. ^ aButton! ! !Morph methodsFor: 'e-toy support' stamp: 'dgd 2/22/2003 14:35'! topEditor "Return the top-most editor around the receiver" | found tested | tested := self. [tested isNil] whileFalse: [tested isTileEditor ifTrue: [found := tested]. tested := tested owner]. ^found! ! !Morph methodsFor: 'e-toy support' stamp: 'dgd 10/8/2003 19:30'! unlockOneSubpart | unlockables aMenu reply | unlockables _ self submorphs select: [:m | m isLocked]. unlockables size <= 1 ifTrue: [^ self unlockContents]. aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m externalName]) selections: unlockables. reply _ aMenu startUpWithCaption: 'Who should be be unlocked?' translated. reply isNil ifTrue: [^ self]. reply unlock! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 11/27/2001 14:52'! wantsRecolorHandle "Answer whether the receiver would like a recoloring halo handle to be put up. Since this handle also presently affords access to the property-sheet, it is presently always allowed, even though SketchMorphs don't like regular recoloring" ^ true ! ! !Morph methodsFor: 'e-toy support' stamp: 'RAA 2/5/2001 15:35'! wrappedInWindowWithTitle: aTitle | aWindow w2 | aWindow _ (SystemWindow labelled: aTitle) model: Model new. aWindow addMorph: self frame: (0@0 extent: 1@1). w2 _ aWindow borderWidth * 2. w2 _ 3. "oh, well" aWindow extent: self fullBounds extent + (0 @ aWindow labelHeight) + (w2 @ w2). ^ aWindow! ! !Morph methodsFor: 'event handling' stamp: 'jcg 10/2/2001 09:26'! doubleClickTimeout: evt "Handle a double-click timeout event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." self eventHandler ifNotNil: [self eventHandler doubleClickTimeout: evt fromMorph: self].! ! !Morph methodsFor: 'event handling' stamp: 'RAA 2/12/2001 15:26'! firstClickTimedOut: evt "Useful for double-click candidates who want to know whether or not the click is a single or double. In this case, ignore the #click: and wait for either this or #doubleClick:" ! ! !Morph methodsFor: 'event handling' stamp: 'nk 2/14/2004 18:42'! handlesMouseDown: evt "Do I want to receive mouseDown events (mouseDown:, mouseMove:, mouseUp:)?" "NOTE: The default response is false, except if you have added sensitivity to mouseDown events using the on:send:to: mechanism. Subclasses that implement these messages directly should override this one to return true." self eventHandler ifNotNil: [^ self eventHandler handlesMouseDown: evt]. ^ false! ! !Morph methodsFor: 'event handling' stamp: 'KTT 6/1/2004 11:41'! keyUp: anEvent "Handle a key up event. The default response is to do nothing."! ! !Morph methodsFor: 'event handling' stamp: 'ar 3/18/2001 17:21'! on: eventName send: selector to: recipient withValue: value "NOTE: selector must take 3 arguments, of which value will be the *** FIRST ***" self eventHandler ifNil: [self eventHandler: EventHandler new]. self eventHandler on: eventName send: selector to: recipient withValue: value ! ! !Morph methodsFor: 'event handling' stamp: 'yo 11/7/2002 18:06'! prefereredKeyboardBounds ^ self bounds: self bounds in: World. ! ! !Morph methodsFor: 'event handling' stamp: 'yo 11/7/2002 18:06'! prefereredKeyboardPosition ^ (self bounds: self bounds in: World) topLeft. ! ! !Morph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:42'! tabAmongFields ^ Preferences tabAmongFields or: [self hasProperty: #tabAmongFields] ! ! !Morph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:36'! transformFrom: uberMorph "Return a transform to be used to map coordinates in a morph above me into my childrens coordinates, or vice-versa. This is used to support scrolling, scaling, and/or rotation. This default implementation just returns my owner's transform or the identity transform if my owner is nil. Note: This method cannot be used to map into the receiver's coordinate system!!" (self == uberMorph or: [owner isNil]) ifTrue: [^IdentityTransform new]. ^owner transformFrom: uberMorph! ! !Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:18'! actionMap "Answer an action map" | actionMap | actionMap := self valueOfProperty: #actionMap. actionMap ifNil: [actionMap _ self createActionMap]. ^ actionMap! ! !Morph methodsFor: 'events-accessing' stamp: 'rw 4/25/2002 07:17'! updateableActionMap "Answer an updateable action map, saving it in my #actionMap property" | actionMap | actionMap := self valueOfProperty: #actionMap. actionMap ifNil: [actionMap _ self createActionMap. self setProperty: #actionMap toValue: actionMap]. ^ actionMap! ! !Morph methodsFor: 'events-processing' stamp: 'nk 3/10/2004 14:30'! handleMouseDown: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. "not interested" anEvent hand removePendingBalloonFor: self. anEvent hand removePendingHaloFor: self. anEvent wasHandled: true. (anEvent controlKeyPressed and: [Preferences cmdGesturesEnabled]) ifTrue: [^ self invokeMetaMenu: anEvent]. "Make me modal during mouse transitions" anEvent hand newMouseFocus: self event: anEvent. anEvent blueButtonChanged ifTrue:[^self blueButtonDown: anEvent]. "this mouse down could be the start of a gesture, or the end of a gesture focus" (self isGestureStart: anEvent) ifTrue: [^ self gestureStart: anEvent]. self mouseDown: anEvent. anEvent hand removeHaloFromClick: anEvent on: self. (self handlesMouseStillDown: anEvent) ifTrue:[ self startStepping: #handleMouseStillDown: at: Time millisecondClockValue + self mouseStillDownThreshold arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ]. ! ! !Morph methodsFor: 'events-processing' stamp: 'ar 8/8/2001 15:29'! handleMouseEnter: anEvent "System level event handling." (anEvent isDraggingEvent) ifTrue:[ (self handlesMouseOverDragging: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseEnterDragging: anEvent]. ^self]. self wantsHalo "If receiver wants halo and balloon, trigger balloon after halo" ifTrue:[anEvent hand triggerHaloFor: self after: self haloDelayTime] ifFalse:[self wantsBalloon ifTrue:[anEvent hand triggerBalloonFor: self after: self balloonHelpDelayTime]]. (self handlesMouseOver: anEvent) ifTrue:[ anEvent wasHandled: true. self mouseEnter: anEvent. ].! ! !Morph methodsFor: 'events-processing' stamp: 'nk 6/13/2004 09:16'! handleMouseMove: anEvent "System level event handling." anEvent wasHandled ifTrue:[^self]. "not interested" "Rules say that by default a morph gets #mouseMove iff * the hand is not dragging anything, + and some button is down, + and the receiver is the current mouse focus." (anEvent hand hasSubmorphs) ifTrue:[^self]. (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: self mouseStillDownStepRate ]. ! ! !Morph methodsFor: 'events-processing' stamp: 'ar 4/23/2001 17:24'! handleMouseOver: anEvent "System level event handling." anEvent hand mouseFocus == self ifTrue:[ "Got this directly through #handleFocusEvent: so check explicitly" (self containsPoint: anEvent position event: anEvent) ifFalse:[^self]]. anEvent hand noticeMouseOver: self event: anEvent! ! !Morph methodsFor: 'events-processing' stamp: 'md 10/22/2003 15:55'! handleUnknownEvent: anEvent "An event of an unknown type was sent to the receiver. What shall we do?!!" Beeper beep. anEvent printString displayAt: 0@0. anEvent wasHandled: true.! ! !Morph methodsFor: 'events-processing' stamp: 'sw 10/5/2002 01:47'! mouseDownPriority "Return the default mouse down priority for the receiver" ^ (self isPartsDonor or: [self isPartsBin]) ifTrue: [50] ifFalse: [0] "The above is a workaround for the complete confusion between parts donors and parts bins. Morphs residing in a parts bin may or may not have the parts donor property set; if they have they may or may not actually handle events. To work around this, parts bins get an equal priority to parts donors so that when a morph in the parts bin does have the property set but does not handle the event we still get a copy from picking it up through the parts bin. Argh. This just *cries* for a cleanup." "And the above comment is Andreas's from 10/2000, which was formerly retrievable by a #flag: call which however caused a problem when trying to recompile the method from decompiled source."! ! !Morph methodsFor: 'events-removing' stamp: 'rw 4/25/2002 07:18'! releaseActionMap "Release the action map" self removeProperty: #actionMap! ! !Morph methodsFor: 'fileIn/out' stamp: 'yo 7/2/2004 13:14'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | aFileName _ ('my {1}' translated format: {self class name}) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".morph" will be added to end)' translated initialAnswer: aFileName. aFileName isEmpty ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.morph'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.morph']. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !Morph methodsFor: 'fileIn/out' stamp: 'dgd 2/22/2003 14:35'! saveOnURLbasic "Ask the user for a url and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | url pg stamp pol | (pg := self valueOfProperty: #SqueakPage) ifNil: [pg := SqueakPage new] ifNotNil: [pg contentsMorph ~~ self ifTrue: [self inform: 'morph''s SqueakPage property is out of date'. pg := SqueakPage new]]. (url := pg url) ifNil: [url := ServerDirectory defaultStemUrl , '1.sp'. "A new legal place" url := FillInTheBlank request: 'url of a place to store this object. Must begin with file:// or ftp://' initialAnswer: url. url isEmpty ifTrue: [^#cancel]]. stamp := Utilities authorInitialsPerSe ifNil: ['*']. pg saveMorph: self author: stamp. SqueakPageCache atURL: url put: pg. "setProperty: #SqueakPage" (pol := pg policy) ifNil: [pol := #neverWrite]. pg policy: #now; dirty: true. pg write. "force the write" pg policy: pol. ^pg! ! !Morph methodsFor: 'fileIn/out' stamp: 'nk 1/6/2004 12:38'! updateFromResource | pathName newMorph f | (pathName := self valueOfProperty: #resourceFilePath) ifNil: [^self]. (pathName asLowercase endsWith: '.morph') ifTrue: [newMorph := (FileStream readOnlyFileNamed: pathName) fileInObjectAndCode. (newMorph isMorph) ifFalse: [^self error: 'Resource not a single morph']] ifFalse: [f := Form fromFileNamed: pathName. f ifNil: [^self error: 'unrecognized image file format']. newMorph := World drawingClass withForm: f]. newMorph setProperty: #resourceFilePath toValue: pathName. self owner replaceSubmorph: self by: newMorph! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! bottom " Return the y-coordinate of my bottom side " ^ bounds bottom! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! bottom: aNumber " Move me so that my bottom is at the y-coordinate aNumber. My extent (width & height) are unchanged " self position: (bounds left @ (aNumber - self height))! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! bottomCenter ^ bounds bottomCenter! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:08'! bottomLeft: aPoint " Move me so that my bottom left corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x) @ (aPoint y - self height)). ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:09'! bottomRight: aPoint " Move me so that my bottom right corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x - bounds width) @ (aPoint y - self height)) ! ! !Morph methodsFor: 'geometry' stamp: 'laza 3/25/2004 21:31'! extent: aPoint bounds extent = aPoint ifTrue: [^ self]. self changed. bounds _ (bounds topLeft extent: aPoint) rounded. self layoutChanged. self changed. ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! height: aNumber " Set my height; my position (top-left corner) and width will remain the same " self extent: self width@aNumber asInteger. ! ! !Morph methodsFor: 'geometry' stamp: 'ar 12/22/2001 22:43'! innerBounds "Return the inner rectangle enclosed by the bounds of this morph excluding the space taken by its borders. For an unbordered morph, this is just its bounds." ^ self bounds insetBy: self borderWidth! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! left " Return the x-coordinate of my left side " ^ bounds left! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! left: aNumber " Move me so that my left side is at the x-coordinate aNumber. My extent (width & height) are unchanged " self position: (aNumber @ bounds top)! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! leftCenter ^ bounds leftCenter! ! !Morph methodsFor: 'geometry' stamp: 'wiz 11/25/2004 12:54'! position: aPoint "Change the position of this morph and and all of its submorphs. " | delta box | delta := aPoint asNonFractionalPoint - bounds topLeft. (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" box := self fullBounds. (delta dotProduct: delta) > 100 ifTrue: ["e.g., more than 10 pixels moved" self invalidRect: box. self invalidRect: (box translateBy: delta)] ifFalse: [self invalidRect: (box merge: (box translateBy: delta))]. self privateFullMoveBy: delta. owner ifNotNil: [owner layoutChanged]! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! right " Return the x-coordinate of my right side " ^ bounds right! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:15'! right: aNumber " Move me so that my right side is at the x-coordinate aNumber. My extent (width & height) are unchanged " self position: ((aNumber - bounds width) @ bounds top)! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! rightCenter ^ bounds rightCenter! ! !Morph methodsFor: 'geometry' stamp: 'tk 7/14/2001 11:11'! setConstrainedPosition: aPoint hangOut: partiallyOutside "Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds. Let me go within two pixels of completely outside if partiallyOutside is true." | trialRect delta boundingMorph bRect | owner ifNil:[^self]. trialRect _ aPoint extent: self bounds extent. boundingMorph _ self topRendererOrSelf owner. delta _ boundingMorph ifNil: [0@0] ifNotNil: [ bRect _ partiallyOutside ifTrue: [boundingMorph bounds insetBy: self extent negated + boundingMorph borderWidth + (2@2)] ifFalse: [boundingMorph bounds]. trialRect amountToTranslateWithin: bRect]. self position: aPoint + delta. self layoutChanged "So that, eg, surrounding text will readjust" ! ! !Morph methodsFor: 'geometry' stamp: 'dgd 8/31/2004 16:22'! shiftSubmorphsBy: delta self shiftSubmorphsOtherThan: (submorphs select: [:m | m wantsToBeTopmost]) by: delta! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:17'! top " Return the y-coordinate of my top side " ^ bounds top! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:14'! top: aNumber " Move me so that my top is at the y-coordinate aNumber. My extent (width & height) are unchanged " self position: (bounds left @ aNumber)! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! topCenter ^ bounds topCenter! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:10'! topLeft: aPoint " Move me so that my top left corner is at aPoint. My extent (width & height) are unchanged " self position: aPoint ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:12'! topRight: aPoint " Move me so that my top right corner is at aPoint. My extent (width & height) are unchanged " self position: ((aPoint x - bounds width) @ (aPoint y)) ! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:22'! width: aNumber " Set my width; my position (top-left corner) and height will remain the same " self extent: aNumber asInteger@self height. ! ! !Morph methodsFor: 'geometry' stamp: 'nk 7/3/2003 19:39'! worldBoundsForHalo "Answer the rectangle to be used as the inner dimension of my halos. Allow for showing either bounds or fullBounds, and compensate for the optional bounds rectangle." | r | r _ (Preferences haloEnclosesFullBounds) ifFalse: [ self boundsIn: nil ] ifTrue: [ self fullBoundsInWorld ]. Preferences showBoundsInHalo ifTrue: [ ^r outsetBy: 1 ]. ^r! ! !Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:18'! color: sensitiveColor sees: soughtColor "Return true if any of my pixels of sensitiveColor intersect with pixels of soughtColor." "Make a mask with black where sensitiveColor is, white elsewhere" | myImage sensitivePixelMask map patchBelowMe tfm morphAsFlexed i1 pasteUp | pasteUp _ self world ifNil: [ ^false ]. tfm := self transformFrom: pasteUp. morphAsFlexed := tfm isIdentity ifTrue: [self] ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm]. myImage := morphAsFlexed imageForm offset: 0 @ 0. sensitivePixelMask := Form extent: myImage extent depth: 1. "ensure at most a 16-bit map" map := Bitmap new: (1 bitShift: (myImage depth - 1 min: 15)). map at: (i1 := sensitiveColor indexInMap: map) put: 1. sensitivePixelMask copyBits: sensitivePixelMask boundingBox from: myImage form at: 0 @ 0 colorMap: map. "get an image of the world below me" patchBelowMe := pasteUp patchAt: morphAsFlexed fullBounds without: self andNothingAbove: false. " sensitivePixelMask displayAt: 0@0. patchBelowMe displayAt: 100@0. " "intersect world pixels of the color we're looking for with the sensitive pixels" map at: i1 put: 0. "clear map and reuse it" map at: (soughtColor indexInMap: map) put: 1. sensitivePixelMask copyBits: patchBelowMe boundingBox from: patchBelowMe at: 0 @ 0 clippingBox: patchBelowMe boundingBox rule: Form and fillColor: nil map: map. " sensitivePixelMask displayAt: 200@0. " ^(sensitivePixelMask tallyPixelValues second) > 0! ! !Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 19:05'! goHome | box | (owner isInMemory and: [owner notNil]) ifTrue: [self visible ifTrue: [box := owner. self left < box left ifTrue: [self position: box left @ self position y]. self right > box right ifTrue: [self position: (box right - self width) @ self position y]. self top < box top ifTrue: [self position: self position x @ box top]. self bottom > box bottom ifTrue: [self position: self position x @ (box bottom - self height)]]]! ! !Morph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 11:00'! scale: newScale "Backstop for morphs that don't have to do something special to set their scale" ! ! !Morph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 10:49'! scaleFactor ^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ] ! ! !Morph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 11:04'! scaleFactor: newScale "Backstop for morphs that don't have to do something special to set their scale " | toBeScaled | toBeScaled := self. newScale = 1.0 ifTrue: [(self heading isZero and: [self isFlexMorph]) ifTrue: [toBeScaled := self removeFlexShell]] ifFalse: [self isFlexMorph ifFalse: [toBeScaled := self addFlexShellIfNecessary]]. toBeScaled scale: newScale. toBeScaled == self ifTrue: [ newScale = 1.0 ifTrue: [ self removeProperty: #scaleFactor ] ifFalse: [ self setProperty: #scaleFactor toValue: newScale ]]! ! !Morph methodsFor: 'geometry eToy' stamp: 'ar 6/12/2001 05:23'! setDirectionFrom: aPoint | delta degrees | delta _ (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees _ delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !Morph methodsFor: 'geometry eToy' stamp: 'nk 7/7/2003 17:19'! touchesColor: soughtColor "Return true if any of my pixels overlap pixels of soughtColor." "Make a shadow mask with black in my shape, white elsewhere" | map patchBelowMe shadowForm tfm morphAsFlexed pasteUp | pasteUp := self world ifNil: [ ^false ]. tfm := self transformFrom: pasteUp. morphAsFlexed := tfm isIdentity ifTrue: [self] ifFalse: [TransformationMorph new flexing: self clone byTransformation: tfm]. shadowForm := morphAsFlexed shadowForm offset: 0 @ 0. "get an image of the world below me" patchBelowMe := (pasteUp patchAt: morphAsFlexed fullBounds without: self andNothingAbove: false) offset: 0 @ 0. " shadowForm displayAt: 0@0. patchBelowMe displayAt: 100@0. " "intersect world pixels of the color we're looking for with our shape." "ensure a maximum 16-bit map" map := Bitmap new: (1 bitShift: (patchBelowMe depth - 1 min: 15)). map at: (soughtColor indexInMap: map) put: 1. shadowForm copyBits: patchBelowMe boundingBox from: patchBelowMe at: 0 @ 0 clippingBox: patchBelowMe boundingBox rule: Form and fillColor: nil map: map. " shadowForm displayAt: 200@0. " ^(shadowForm tallyPixelValues second) > 0! ! !Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 14:37'! x "Return my horizontal position relative to the cartesian origin of a relevant playfield" | aPlayfield | aPlayfield := self referencePlayfield. ^aPlayfield isNil ifTrue: [self referencePosition x] ifFalse: [self referencePosition x - aPlayfield cartesianOrigin x]! ! !Morph methodsFor: 'geometry eToy' stamp: 'aoy 2/17/2003 01:00'! x: aNumber "Set my horizontal position relative to the cartesian origin of the playfield or the world." | offset aPlayfield newX | aPlayfield := self referencePlayfield. offset := self left - self referencePosition x. newX := aPlayfield isNil ifTrue: [aNumber + offset] ifFalse: [aPlayfield cartesianOrigin x + aNumber + offset]. self position: newX @ bounds top! ! !Morph methodsFor: 'geometry eToy' stamp: 'dgd 2/22/2003 14:37'! y "Return my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen." | w aPlayfield | w := self world. w ifNil: [^bounds top]. aPlayfield := self referencePlayfield. ^aPlayfield isNil ifTrue: [w cartesianOrigin y - self referencePosition y] ifFalse: [aPlayfield cartesianOrigin y - self referencePosition y]! ! !Morph methodsFor: 'geometry eToy' stamp: 'aoy 2/17/2003 01:00'! y: aNumber "Set my vertical position relative to the cartesian origin of the playfield or the world. Note that larger y values are closer to the top of the screen." | w offset newY aPlayfield | w := self world. w ifNil: [^self position: bounds left @ aNumber]. aPlayfield := self referencePlayfield. offset := self top - self referencePosition y. newY := aPlayfield isNil ifTrue: [w bottom - aNumber + offset] ifFalse: [aPlayfield cartesianOrigin y - aNumber + offset]. self position: bounds left @ newY! ! !Morph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 14:33'! obtrudesBeyondContainer "Answer whether the receiver obtrudes beyond the bounds of its container" | top | top := self topRendererOrSelf. (top owner isNil or: [top owner isHandMorph]) ifTrue: [^false]. ^(top owner bounds containsRect: top bounds) not! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/30/2004 02:53'! addHandlesTo: aHaloMorph box: box "Add halo handles to the halo. Apply the halo filter if appropriate" | wantsIt aSelector | aHaloMorph haloBox: box. Preferences haloSpecifications do: [:aSpec | aSelector _ aSpec addHandleSelector. wantsIt _ Preferences selectiveHalos ifTrue: [self wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph] ifFalse: [true]. wantsIt ifTrue: [(#(addMakeSiblingHandle: addDupHandle:) includes: aSelector) ifTrue: [wantsIt _ self preferredDuplicationHandleSelector = aSelector]. wantsIt ifTrue: [aHaloMorph perform: aSelector with: aSpec]]]. aHaloMorph innerTarget addOptionalHandlesTo: aHaloMorph box: box! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 17:31'! addMagicHaloFor: aHand | halo prospectiveHaloClass | aHand halo ifNotNil:[ aHand halo target == self ifTrue:[^self]. aHand halo isMagicHalo ifFalse:[^self]]. prospectiveHaloClass _ Smalltalk at: self haloClass ifAbsent: [HaloMorph]. halo _ prospectiveHaloClass new bounds: self worldBoundsForHalo. halo popUpMagicallyFor: self hand: aHand.! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:29'! balloonFont ^ self valueOfProperty: #balloonFont ifAbsent: [self defaultBalloonFont]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:30'! balloonFont: aFont ^ self setProperty: #balloonFont toValue: aFont! ! !Morph methodsFor: 'halos and balloon help' stamp: 'dgd 9/7/2004 18:35'! balloonHelpDelayTime "Return the number of milliseconds before a balloon help should be put up on the receiver. The balloon help will only be put up if the receiver responds to #wantsBalloon by returning true." ^ Preferences balloonHelpDelayTime! ! !Morph methodsFor: 'halos and balloon help' stamp: 'yo 3/17/2005 16:01'! balloonHelpTextForHandle: aHandle "Answer a string providing balloon help for the given halo handle" | itsSelector | itsSelector _ aHandle eventHandler firstMouseSelector. #( (addFullHandles 'More halo handles') (addSimpleHandles 'Fewer halo handles') (chooseEmphasisOrAlignment 'Emphasis & alignment') (chooseFont 'Change font') (chooseNewGraphicFromHalo 'Choose a new graphic') (chooseStyle 'Change style') (dismiss 'Remove') (doDebug:with: 'Debug (press shift to inspect morph)') (doDirection:with: 'Choose forward direction') (doDup:with: 'Duplicate') (doDupOrMakeSibling:with: 'Duplicate (press shift to make a sibling)') (doMakeSiblingOrDup:with: 'Make a sibling (press shift to make simple duplicate)') (doMakeSibling:with: 'Make a sibling') (doMenu:with: 'Menu') (doGrab:with: 'Pick up') (editButtonsScript 'See the script for this button') (editDrawing 'Repaint') (maybeDoDup:with: 'Duplicate') (makeNascentScript 'Make a scratch script') (makeNewDrawingWithin 'Paint new object') (mouseDownInCollapseHandle:with: 'Collapse') (mouseDownOnHelpHandle: 'Help') (openViewerForArgument 'Open a Viewer for me') (openViewerForTarget:with: 'Open a Viewer for me') (paintBackground 'Paint background') (prepareToTrackCenterOfRotation:with: 'Move object or set center of rotation') (presentViewMenu 'Present the Viewing menu') (startDrag:with: 'Move') (startGrow:with: 'Change size (press shift to preserve aspect)') (startRot:with: 'Rotate') (startScale:with: 'Change scale') (tearOffTile 'Make a tile representing this object') (tearOffTileForTarget:with: 'Make a tile representing this object') (trackCenterOfRotation:with: 'Set center of rotation')) do: [:pair | itsSelector == pair first ifTrue: [^ pair last]]. (itsSelector == #mouseDownInDimissHandle:with:) ifTrue: [^ Preferences preserveTrash ifTrue: ['Move to trash'] ifFalse: ['Remove from screen']]. (itsSelector == #doRecolor:with:) ifTrue: [ ^ Preferences propertySheetFromHalo ifTrue: ['Property Sheet (press shift for simple recolor)'] ifFalse: ['Change color (press shift for more properties)']]. ^ 'unknown halo handle'! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'! defaultBalloonFont ^ BalloonMorph balloonFont! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 3/17/2001 13:19'! halo (self outermostWorldMorph ifNil: [^nil]) haloMorphs do: [:h | h target == self ifTrue: [^ h]]. ^ nil! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 8/8/2001 15:40'! haloDelayTime "Return the number of milliseconds before a halo should be put up on the receiver. The halo will only be put up if the receiver responds to #wantsHalo by returning true." ^800! ! !Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/22/2003 19:05'! isLikelyRecipientForMouseOverHalos ^self player notNil! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/15/2001 12:23'! okayToAddDismissHandle "Answer whether a halo on the receiver should offer a dismiss handle. This provides a hook for making it harder to disassemble some strucures even momentarily" ^ self holdsSeparateDataForEachInstance not and: [self resistsRemoval not]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:50'! okayToBrownDragEasily "Answer whether it it okay for the receiver to be brown-dragged easily -- i.e. repositioned within its container without extracting it. At present this is just a hook -- nobody declines." ^ true " ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: [self layoutPolicy isNil]"! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 15:02'! okayToExtractEasily "Answer whether it it okay for the receiver to be extracted easily. Not yet hooked up to the halo-permissions mechanism." ^ self topRendererOrSelf owner dragNDropEnabled! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/29/2001 06:29'! okayToResizeEasily "Answer whether it is appropriate to have the receiver be easily resized by the user from the halo" ^ true "This one was too jarring, not that it didn't most of the time do the right thing but because some of the time it didn't, such as in a holder. If we pursue this path, the test needs to be airtight, obviously... ^ (self topRendererOrSelf owner isKindOf: PasteUpMorph) and: [self layoutPolicy isNil]"! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:44'! okayToRotateEasily "Answer whether it is appropriate for a rotation handle to be shown for the receiver. This is a hook -- at present nobody declines." ^ true! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/31/2004 03:30'! preferredDuplicationHandleSelector "Answer the selector, either #addMakeSiblingHandle: or addDupHandle:, to be offered as the default in a halo open on me" Preferences oliveHandleForScriptedObjects ifFalse: [^ #addDupHandle:]. ^ self renderedMorph valueOfProperty: #preferredDuplicationHandleSelector ifAbsent: [self player class isUniClass ifTrue: [#addMakeSiblingHandle:] ifFalse: [#addDupHandle:]]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/16/2003 19:30'! setBalloonText: stringOrText maxLineLength: aLength "Set receiver's balloon help text. Pass nil to remove the help." (self hasExtension not and: [stringOrText isNil]) ifTrue: [^ self]. self assureExtension balloonText: (stringOrText ifNotNil: [stringOrText asString withNoLineLongerThan: aLength])! ! !Morph methodsFor: 'halos and balloon help' stamp: 'nk 8/13/2003 08:48'! transferHalo: event from: formerHaloOwner "Progressively transfer the halo to the next likely recipient" | localEvt w target | self flag: #workAround. "For halo's distinction between 'target' and 'innerTarget' we need to bypass any renderers." (formerHaloOwner == self and:[self isRenderer and:[self wantsHaloFromClick not]]) ifTrue:[ event shiftPressed ifTrue:[ target _ owner. localEvt _ event transformedBy: (self transformedFrom: owner). ] ifFalse:[ target _ self renderedMorph. localEvt _ event transformedBy: (target transformedFrom: self). ]. ^target transferHalo: localEvt from: target]. "Never transfer halo to top-most world" (self isWorldMorph and:[owner isNil]) ifFalse:[ (self wantsHaloFromClick and:[formerHaloOwner ~~ self]) ifTrue:[^self addHalo: event from: formerHaloOwner]]. event shiftPressed ifTrue:[ "Pass it outwards" owner ifNotNil:[^owner transferHalo: event from: formerHaloOwner]. "We're at the top level; throw the event back in to find recipient" formerHaloOwner removeHalo. ^self processEvent: event copy resetHandlerFields. ]. self submorphsDo:[:m| localEvt _ event transformedBy: (m transformedFrom: self). (m fullContainsPoint: localEvt position) ifTrue:[^m transferHalo: event from: formerHaloOwner]. ]. "We're at the bottom most level; throw the event back up to the root to find recipient" formerHaloOwner removeHalo. (w _ self world) ifNil: [ ^self ]. localEvt _ event transformedBy: (self transformedFrom: w) inverseTransformation. ^w processEvent: localEvt resetHandlerFields. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'rhi 10/5/2001 20:49'! wantsBalloon "Answer true if receiver wants to show a balloon help text is a few moments." ^ (self balloonText notNil) and: [Preferences balloonHelpEnabled]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:50'! wantsDirectionHandles ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[Preferences showDirectionHandles]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'ar 11/29/2001 19:52'! wantsDirectionHandles: aBool aBool == Preferences showDirectionHandles ifTrue:[self removeProperty: #wantsDirectionHandles] ifFalse:[self setProperty: #wantsDirectionHandles toValue: aBool]. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'dgd 2/22/2003 19:06'! wantsHalo | topOwner | ^(topOwner := self topRendererOrSelf owner) notNil and: [topOwner wantsHaloFor: self]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 11/27/2001 14:49'! wantsHaloHandleWithSelector: aSelector inHalo: aHaloMorph "Answer whether the receiver would like to offer the halo handle with the given selector (e.g. #addCollapseHandle:)" (#(addDismissHandle:) includes: aSelector) ifTrue: [^ self resistsRemoval not]. (#( addDragHandle: ) includes: aSelector) ifTrue: [^ self okayToBrownDragEasily]. (#(addGrowHandle: addScaleHandle:) includes: aSelector) ifTrue: [^ self okayToResizeEasily]. (#( addRotateHandle: ) includes: aSelector) ifTrue: [^ self okayToRotateEasily]. (#(addRecolorHandle:) includes: aSelector) ifTrue: [^ self renderedMorph wantsRecolorHandle]. true ifTrue: [^ true] ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'nk 6/12/2004 09:32'! wantsSimpleSketchMorphHandles "Answer true if my halo's simple handles should include the simple sketch morph handles." ^false! ! !Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:00'! basicInitialize "Do basic generic initialization of the instance variables: Set up the receiver, created by a #basicNew and now ready to be initialized, by placing initial values in the instance variables as appropriate" owner _ nil. submorphs _ EmptyArray. bounds _ self defaultBounds. color _ self defaultColor! ! !Morph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:06'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 corner: 50 @ 40! ! !Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !Morph methodsFor: 'initialization' stamp: 'sw 6/26/2001 10:56'! inATwoWayScrollPane "Answer a two-way scroll pane that allows the user to scroll the receiver in either direction. It will have permanent scroll bars unless you take some special action." | widget | widget _ TwoWayScrollPane new. widget extent: ((self width min: 300 max: 100) @ (self height min: 150 max: 100)); borderWidth: 0. widget scroller addMorph: self. widget setScrollDeltas. widget color: self color darker darker. ^ widget! ! !Morph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 17:30'! initialize "initialize the state of the receiver" owner _ nil. submorphs _ EmptyArray. bounds _ self defaultBounds. color _ self defaultColor! ! !Morph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:28'! resourceJustLoaded "In case resource relates to me" self releaseCachedState.! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:31'! doLayoutIn: layoutBounds "Compute a new layout based on the given layout bounds." "Note: Testing for #bounds or #layoutBounds would be sufficient to figure out if we need an invalidation afterwards but #outerBounds is what we need for all leaf nodes so we use that." | layout box priorBounds | priorBounds := self outerBounds. submorphs isEmpty ifTrue: [^fullBounds := priorBounds]. "Send #ownerChanged to our children" submorphs do: [:m | m ownerChanged]. layout := self layoutPolicy. layout ifNotNil: [layout layout: self in: layoutBounds]. self adjustLayoutBounds. fullBounds := self privateFullBounds. box := self outerBounds. box = priorBounds ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! ! !Morph methodsFor: 'layout' stamp: 'ar 1/1/2002 20:00'! fullBounds "Return the bounding box of the receiver and all its children. Recompute the layout if necessary." fullBounds ifNotNil:[^fullBounds]. "Errors at this point can be critical so make sure we catch 'em all right" [self doLayoutIn: self layoutBounds] on: Error do:[:ex| "This should do it unless you don't screw up the bounds" fullBounds _ bounds. ex pass]. ^fullBounds! ! !Morph methodsFor: 'layout' stamp: 'ar 8/6/2001 09:55'! layoutInBounds: cellBounds "Layout specific. Apply the given bounds to the receiver after being layed out in its owner." | box aSymbol delta | fullBounds ifNil:["We are getting new bounds here but we haven't computed the receiver's layout yet. Although the receiver has reported its minimal size before the actual size it has may differ from what would be after the layout. Normally, this isn't a real problem, but if we have #shrinkWrap constraints then the receiver's bounds may be larger than the cellBounds. THAT is a problem because the centering may not work correctly if the receiver shrinks after the owner layout has been computed. To avoid this problem, we compute the receiver's layout now. Note that the layout computation is based on the new cell bounds rather than the receiver's current bounds." cellBounds origin = self bounds origin ifFalse:[ box _ self outerBounds. delta _ cellBounds origin - self bounds origin. self invalidRect: (box merge: (box translateBy: delta)). self privateFullMoveBy: delta]. "sigh..." box _ cellBounds origin extent: "adjust for #rigid receiver" (self hResizing == #rigid ifTrue:[self bounds extent x] ifFalse:[cellBounds extent x]) @ (self vResizing == #rigid ifTrue:[self bounds extent y] ifFalse:[cellBounds extent y]). "Compute inset of layout bounds" box _ box origin - (self bounds origin - self layoutBounds origin) corner: box corner - (self bounds corner - self layoutBounds corner). "And do the layout within the new bounds" self layoutBounds: box. self doLayoutIn: box]. cellBounds = self fullBounds ifTrue:[^self]. "already up to date" cellBounds extent = self fullBounds extent "nice fit" ifTrue:[^self position: cellBounds origin]. box _ bounds. "match #spaceFill constraints" self hResizing == #spaceFill ifTrue:[box _ box origin extent: cellBounds width @ box height]. self vResizing == #spaceFill ifTrue:[box _ box origin extent: box width @ cellBounds height]. "align accordingly" aSymbol _ (owner ifNil:[self]) cellPositioning. box _ box align: (box perform: aSymbol) with: (cellBounds perform: aSymbol). "and install new bounds" self bounds: box.! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! minExtent "Layout specific. Return the minimum size the receiver can be represented in. Implementation note: When this message is sent from an owner trying to lay out its children it will traverse down the morph tree and recompute the minimal arrangement of the morphs based on which the minimal extent is returned. When a morph with some layout strategy is encountered, the morph will ask its strategy to compute the new arrangement. However, since the final size given to the receiver is unknown at the point of the query, the assumption is made that the current bounds of the receiver are the base on which the layout should be computed. This scheme prevents strange layout changes when for instance, a table is contained in another table. Unless the inner table has been resized manually (which means its bounds are already enlarged) the arrangement of the inner table will not change here. Thus the entire layout computation is basically an iterative process which may have different results depending on the incremental changes applied." | layout minExtent extra hFit vFit | hFit := self hResizing. vFit := self vResizing. (hFit == #spaceFill or: [vFit == #spaceFill]) ifFalse: ["The receiver will not adjust to parents layout by growing or shrinking, which means that an accurate layout defines the minimum size." ^self fullBounds extent]. "An exception -- a receiver with #shrinkWrap constraints but no children is being treated #rigid (the equivalent to a #spaceFill receiver in a non-layouting owner)" self hasSubmorphs ifFalse: [hFit == #shrinkWrap ifTrue: [hFit := #rigid]. vFit == #shrinkWrap ifTrue: [vFit := #rigid]]. layout := self layoutPolicy. layout isNil ifTrue: [minExtent := 0 @ 0] ifFalse: [minExtent := layout minExtentOf: self in: self layoutBounds]. hFit == #rigid ifTrue: [minExtent := self fullBounds extent x @ minExtent y] ifFalse: [extra := self bounds width - self layoutBounds width. minExtent := (minExtent x + extra) @ minExtent y]. minExtent := vFit == #rigid ifTrue: [minExtent x @ self fullBounds extent y] ifFalse: [extra := self bounds height - self layoutBounds height. minExtent x @ (minExtent y + extra)]. minExtent := minExtent max: self minWidth @ self minHeight. ^minExtent! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:52'! minHeight "answer the receiver's minHeight" ^ self valueOfProperty: #minHeight ifAbsent: [2]! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! minHeight: aNumber aNumber isNil ifTrue: [self removeProperty: #minHeight] ifFalse: [self setProperty: #minHeight toValue: aNumber]. self layoutChanged! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'! minWidth "answer the receiver's minWidth" ^ self valueOfProperty: #minWidth ifAbsent: [2]! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! minWidth: aNumber aNumber isNil ifTrue: [self removeProperty: #minWidth] ifFalse: [self setProperty: #minWidth toValue: aNumber]. self layoutChanged! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:33'! privateFullBounds "Private. Compute the actual full bounds of the receiver" | box | submorphs isEmpty ifTrue: [^self outerBounds]. box := self outerBounds copy. box := box quickMerge: (self clipSubmorphs ifTrue: [self submorphBounds intersect: self clippingBounds] ifFalse: [self submorphBounds]). ^box origin asIntegerPoint corner: box corner asIntegerPoint! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:57'! addCellLayoutMenuItems: aMenu hand: aHand "Cell (e.g., child) related items" | menu sub | menu _ MenuMorph new defaultTarget: self. menu addUpdating: #hasDisableTableLayoutString action: #changeDisableTableLayout. menu addLine. sub _ MenuMorph new defaultTarget: self. #(rigid shrinkWrap spaceFill) do:[:sym| sub addUpdating: #hResizingString: target: self selector: #hResizing: argumentList: (Array with: sym)]. menu add:'horizontal resizing' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(rigid shrinkWrap spaceFill) do:[:sym| sub addUpdating: #vResizingString: target: self selector: #vResizing: argumentList: (Array with: sym)]. menu add:'vertical resizing' translated subMenu: sub. aMenu ifNotNil:[aMenu add: 'child layout' translated subMenu: menu]. ^menu! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:51'! addLayoutMenuItems: topMenu hand: aHand | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addUpdating: #hasNoLayoutString action: #changeNoLayout. aMenu addUpdating: #hasProportionalLayoutString action: #changeProportionalLayout. aMenu addUpdating: #hasTableLayoutString action: #changeTableLayout. aMenu addLine. aMenu add: 'change layout inset...' translated action: #changeLayoutInset:. aMenu addLine. self addCellLayoutMenuItems: aMenu hand: aHand. self addTableLayoutMenuItems: aMenu hand: aHand. topMenu ifNotNil:[topMenu add: 'layout' translated subMenu: aMenu]. ^aMenu! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:07'! addTableLayoutMenuItems: aMenu hand: aHand | menu sub | menu _ MenuMorph new defaultTarget: self. menu addUpdating: #hasReverseCellsString action: #changeReverseCells. menu addUpdating: #hasClipLayoutCellsString action: #changeClipLayoutCells. menu addUpdating: #hasRubberBandCellsString action: #changeRubberBandCells. menu addLine. menu add: 'change cell inset...' translated action: #changeCellInset:. menu add: 'change min cell size...' translated action: #changeMinCellSize:. menu add: 'change max cell size...' translated action: #changeMaxCellSize:. menu addLine. sub _ MenuMorph new defaultTarget: self. #(leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| sub addUpdating: #listDirectionString: target: self selector: #changeListDirection: argumentList: (Array with: sym)]. menu add: 'list direction' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(none leftToRight rightToLeft topToBottom bottomToTop) do:[:sym| sub addUpdating: #wrapDirectionString: target: self selector: #wrapDirection: argumentList: (Array with: sym)]. menu add: 'wrap direction' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(center topLeft topRight bottomLeft bottomRight topCenter leftCenter rightCenter bottomCenter) do:[:sym| sub addUpdating: #cellPositioningString: target: self selector: #cellPositioning: argumentList: (Array with: sym)]. menu add: 'cell positioning' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(topLeft bottomRight center justified) do:[:sym| sub addUpdating: #listCenteringString: target: self selector: #listCentering: argumentList: (Array with: sym)]. menu add: 'list centering' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(topLeft bottomRight center justified) do:[:sym| sub addUpdating: #wrapCenteringString: target: self selector: #wrapCentering: argumentList: (Array with: sym)]. menu add: 'wrap centering' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(none equal) do:[:sym| sub addUpdating: #listSpacingString: target: self selector: #listSpacing: argumentList: (Array with: sym)]. menu add: 'list spacing' translated subMenu: sub. sub _ MenuMorph new defaultTarget: self. #(none localRect localSquare globalRect globalSquare) do:[:sym| sub addUpdating: #cellSpacingString: target: self selector: #cellSpacing: argumentList: (Array with: sym)]. menu add: 'cell spacing' translated subMenu: sub. aMenu ifNotNil:[aMenu add: 'table layout' translated subMenu: menu]. ^menu! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'! hasClipLayoutCellsString ^ (self clipLayoutCells ifTrue: ['<on>'] ifFalse: ['<off>']), 'clip to cell size' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:58'! hasDisableTableLayoutString ^ (self disableTableLayout ifTrue: ['<on>'] ifFalse: ['<off>']) , 'disable layout in tables' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 10/8/2003 19:23'! hasNoLayoutString ^ (self layoutPolicy isNil ifTrue: ['<on>'] ifFalse: ['<off>']) , 'no layout' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:55'! hasProportionalLayoutString | layout | ^ (((layout := self layoutPolicy) notNil and: [layout isProportionalLayout]) ifTrue: ['<on>'] ifFalse: ['<off>']) , 'proportional layout' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:08'! hasReverseCellsString ^ (self reverseTableCells ifTrue: ['<on>'] ifFalse: ['<off>']), 'reverse table cells' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 20:09'! hasRubberBandCellsString ^ (self rubberBandCells ifTrue: ['<on>'] ifFalse: ['<off>']), 'rubber band cells' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 8/30/2003 16:59'! hasTableLayoutString | layout | ^ (((layout := self layoutPolicy) notNil and: [layout isTableLayout]) ifTrue: ['<on>'] ifFalse: ['<off>']) , 'table layout' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'dgd 10/19/2003 11:23'! layoutMenuPropertyString: aSymbol from: currentSetting | onOff wording | onOff := aSymbol == currentSetting ifTrue: ['<on>'] ifFalse: ['<off>']. "" wording := String streamContents: [:stream | | index | index := 1. aSymbol keysAndValuesDo: [:idx :ch | ch isUppercase ifTrue: [""stream nextPutAll: (aSymbol copyFrom: index to: idx - 1) asLowercase. stream nextPutAll: ' '. index := idx]]. index < aSymbol size ifTrue: [stream nextPutAll: (aSymbol copyFrom: index to: aSymbol size) asLowercase]]. "" ^ onOff , wording translated! ! !Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:07'! layoutFrame "Layout specific. Return the layout frame describing where the receiver should appear in a proportional layout" ^ self hasExtension ifTrue: [ self extension layoutFrame]! ! !Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:07'! layoutPolicy "Layout specific. Return the layout policy describing how children of the receiver should appear." ^ self hasExtension ifTrue: [ self extension layoutPolicy]! ! !Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:07'! layoutProperties "Return the current layout properties associated with the receiver" ^ self hasExtension ifTrue: [self extension layoutProperties]! ! !Morph methodsFor: 'layout-properties' stamp: 'dgd 2/16/2003 20:02'! spaceFillWeight "Layout specific. This property describes the relative weight that should be given to the receiver when extra space is distributed between different #spaceFill cells." ^ self valueOfProperty: #spaceFillWeight ifAbsent: [1]! ! !Morph methodsFor: 'layout-properties' stamp: 'tk 10/30/2001 18:39'! vResizeToFit: aBoolean aBoolean ifTrue:[ self vResizing: #shrinkWrap. ] ifFalse:[ self vResizing: #rigid. ].! ! !Morph methodsFor: 'macpal' stamp: 'sw 5/17/2001 17:57'! currentVocabulary "Answer the receiver's current vocabulary" | outer | ^ (outer _ self ownerThatIsA: StandardViewer orA: ScriptEditorMorph) ifNotNil: [outer currentVocabulary] ifNil: [super currentVocabulary]! ! !Morph methodsFor: 'menu' stamp: 'sw 11/27/2001 15:21'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Probably one could offer border-style items even if it's not a borderedMorph, so this remains a loose end for the moment" ! ! !Morph methodsFor: 'menu' stamp: 'nk 2/15/2004 09:08'! addGestureMenuItems: aMenu hand: aHandMorph "If the receiver wishes the Genie menu items, add a line to the menu and then those Genie items, else do nothing"! ! !Morph methodsFor: 'menus' stamp: 'sw 10/6/2004 11:38'! absorbStateFromRenderer: aRenderer "Transfer knownName, actorState, visible, and player info over from aRenderer, which was formerly imposed above me as a transformation shell but is now going away." | current | (current _ aRenderer actorStateOrNil) ifNotNil: [self actorState: current. aRenderer actorState: nil]. (current _ aRenderer knownName) ifNotNil: [self setNameTo: current. aRenderer setNameTo: nil]. (current _ aRenderer player) ifNotNil: [self player: current. current rawCostume: self. aRenderer player: nil]. self visible: aRenderer visible! ! !Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 14:36'! addAddHandMenuItemsForHalo: aMenu hand: aHandMorph "The former charter of this method was to add halo menu items that pertained specifically to the hand. Over time this charter has withered, and most morphs reimplement this method simply to add their morph-specific menu items. So in the latest round, all other implementors in the standard image have been removed. However, this is left here as a hook for the benefit of existing code in client uses." ! ! !Morph methodsFor: 'menus' stamp: 'dgd 11/15/2003 19:25'! addCopyItemsTo: aMenu "Add copy-like items to the halo menu" | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:. subMenu add: 'copy text' translated action: #clipText. subMenu add: 'copy Postscript' translated action: #clipPostscript. subMenu add: 'print Postscript to file...' translated target: self selector: #printPSToFile. aMenu add: 'copy & print...' translated subMenu: subMenu! ! !Morph methodsFor: 'menus' stamp: 'sw 11/27/2001 07:17'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add morph-specific items to the given menu which was invoked by the given hand. This method provides is invoked both from the halo-menu and from the control-menu regimes." ! ! !Morph methodsFor: 'menus' stamp: 'nk 2/16/2004 13:29'! addExportMenuItems: aMenu hand: aHandMorph "Add export items to the menu" aMenu ifNotNil: [ | aSubMenu | aSubMenu _ MenuMorph new defaultTarget: self. aSubMenu add: 'BMP file' translated action: #exportAsBMP. aSubMenu add: 'GIF file' translated action: #exportAsGIF. aSubMenu add: 'JPEG file' translated action: #exportAsJPEG. aSubMenu add: 'PNG file' translated action: #exportAsPNG. aMenu add: 'export...' translated subMenu: aSubMenu] ! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 16:44'! addFillStyleMenuItems: aMenu hand: aHand "Add the items for changing the current fill style of the Morph" | menu | self canHaveFillStyles ifFalse:[^aMenu add: 'change color...' translated target: self action: #changeColor]. menu _ MenuMorph new defaultTarget: self. self fillStyle addFillStyleMenuItems: menu hand: aHand from: self. menu addLine. menu add: 'solid fill' translated action: #useSolidFill. menu add: 'gradient fill' translated action: #useGradientFill. menu add: 'bitmap fill' translated action: #useBitmapFill. menu add: 'default fill' translated action: #useDefaultFill. aMenu add: 'fill style' translated subMenu: menu. "aMenu add: 'change color...' translated action: #changeColor"! ! !Morph methodsFor: 'menus' stamp: 'sw 7/28/2004 16:23'! addHaloActionsTo: aMenu "Add items to aMenu representing actions requestable via halo" | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu addTitle: self externalName. subMenu addStayUpItemSpecial. subMenu addLine. subMenu add: 'delete' translated action: #dismissViaHalo. subMenu balloonTextForLastItem: 'Delete this object -- warning -- can be destructive!!' translated. self maybeAddCollapseItemTo: subMenu. subMenu add: 'grab' translated action: #openInHand. subMenu balloonTextForLastItem: 'Pick this object up -- warning, since this removes it from its container, it can have adverse effects.' translated. subMenu addLine. subMenu add: 'resize' translated action: #resizeFromMenu. subMenu balloonTextForLastItem: 'Change the size of this object' translated. subMenu add: 'duplicate' translated action: #maybeDuplicateMorph. subMenu balloonTextForLastItem: 'Hand me a copy of this object' translated. "Note that this allows access to the non-instancing duplicate even when this is a uniclass instance" subMenu add: 'make a sibling' translated action: #handUserASibling. subMenu balloonTextForLastItem: 'Make a new sibling of this object and hand it to me' translated. subMenu addLine. subMenu add: 'property sheet' translated target: self renderedMorph action: #openAPropertySheet. subMenu balloonTextForLastItem: 'Open a property sheet for me. Allows changing lots of stuff at once.' translated. subMenu add: 'set color' translated target: self renderedMorph action: #changeColor. subMenu balloonTextForLastItem: 'Change the color of this object' translated. subMenu add: 'viewer' translated target: self action: #beViewed. subMenu balloonTextForLastItem: 'Open a Viewer that will allow everything about this object to be seen and controlled.' translated. subMenu add: 'tile browser' translated target: self action: #openInstanceBrowserWithTiles. subMenu balloonTextForLastItem: 'Open a tool that will facilitate tile scripting of this object.' translated. subMenu add: 'hand me a tile' translated target: self action: #tearOffTile. subMenu balloonTextForLastItem: 'Hand me a tile represting this object' translated. subMenu addLine. subMenu add: 'inspect' translated target: self action: #inspect. subMenu balloonTextForLastItem: 'Open an Inspector on this object' translated. aMenu add: 'halo actions...' translated subMenu: subMenu ! ! !Morph methodsFor: 'menus' stamp: 'sw 3/2/2004 22:11'! addMiscExtrasTo: aMenu "Add a submenu of miscellaneous extra items to the menu." | realOwner realMorph subMenu | subMenu _ MenuMorph new defaultTarget: self. (self isWorldMorph not and: [(self renderedMorph isSystemWindow) not]) ifTrue: [subMenu add: 'put in a window' translated action: #embedInWindow]. self isWorldMorph ifFalse: [subMenu add: 'adhere to edge...' translated action: #adhereToEdge. subMenu addLine]. realOwner _ (realMorph _ self topRendererOrSelf) owner. (realOwner isKindOf: TextPlusPasteUpMorph) ifTrue: [subMenu add: 'GeeMail stuff...' translated subMenu: (realOwner textPlusMenuFor: realMorph)]. subMenu add: 'add mouse up action' translated action: #addMouseUpAction; add: 'remove mouse up action' translated action: #removeMouseUpAction; add: 'hand me tiles to fire this button' translated action: #handMeTilesToFire. subMenu addLine. subMenu add: 'arrowheads on pen trails...' translated action: #setArrowheads. subMenu addLine. subMenu defaultTarget: self topRendererOrSelf. subMenu add: 'draw new path' translated action: #definePath. subMenu add: 'follow existing path' translated action: #followPath. subMenu add: 'delete existing path' translated action: #deletePath. subMenu addLine. self addGestureMenuItems: subMenu hand: ActiveHand. aMenu add: 'extras...' translated subMenu: subMenu! ! !Morph methodsFor: 'menus' stamp: 'nk 1/6/2004 12:53'! addPaintingItemsTo: aMenu hand: aHandMorph | subMenu movies | subMenu := MenuMorph new defaultTarget: self. subMenu add: 'repaint' translated action: #editDrawing. subMenu add: 'set rotation center' translated action: #setRotationCenter. subMenu add: 'reset forward-direction' translated action: #resetForwardDirection. subMenu add: 'set rotation style' translated action: #setRotationStyle. subMenu add: 'erase pixels of color' translated action: #erasePixelsOfColor:. subMenu add: 'recolor pixels of color' translated action: #recolorPixelsOfColor:. subMenu add: 'reduce color palette' translated action: #reduceColorPalette:. subMenu add: 'add a border around this shape...' translated action: #addBorderToShape:. movies := (self world rootMorphsAt: aHandMorph targetOffset) select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]]. movies size > 1 ifTrue: [subMenu add: 'insert into movie' translated action: #insertIntoMovie:]. aMenu add: 'painting...' translated subMenu: subMenu! ! !Morph methodsFor: 'menus' stamp: 'sw 1/1/2005 01:03'! addPlayerItemsTo: aMenu "Add player-related items to the menu if appropriate" | aPlayer subMenu | aPlayer _ self topRendererOrSelf player. subMenu _ MenuMorph new defaultTarget: self. subMenu add: 'make a sibling instance' translated target: self action: #makeNewPlayerInstance:. subMenu balloonTextForLastItem: 'Makes another morph whose player is of the same class as this one. Both siblings will share the same scripts' translated. subMenu add: 'make multiple siblings...' translated target: self action: #makeMultipleSiblings:. subMenu balloonTextForLastItem: 'Make any number of sibling instances all at once' translated. (aPlayer belongsToUniClass and: [aPlayer class instanceCount > 1]) ifTrue: [subMenu addLine. subMenu add: 'make all siblings look like me' translated target: self action: #makeSiblingsLookLikeMe:. subMenu balloonTextForLastItem: 'make all my sibling instances look like me.' translated. subMenu add: 'bring all siblings to my location' translated target: self action: #bringAllSiblingsToMe:. subMenu balloonTextForLastItem: 'find all sibling instances and bring them to me' translated. subMenu add: 'apply status to all siblngs' translated target: self action: #applyStatusToAllSiblings:. subMenu balloonTextForLastItem: 'apply the current status of all of my scripts to the scripts of all my siblings' translated]. subMenu add: 'indicate all siblings' translated target: self action: #indicateAllSiblings. subMenu balloonTextForLastItem: 'momentarily show, by flashing , all of my visible siblings.'. aMenu add: 'siblings...' translated subMenu: subMenu ! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:34'! addStackItemsTo: aMenu "Add stack-related items to the menu" | stackSubMenu | stackSubMenu _ MenuMorph new defaultTarget: self. (owner notNil and: [owner isStackBackground]) ifTrue: [self isShared ifFalse: [self couldHoldSeparateDataForEachInstance ifTrue: [stackSubMenu add: 'Background field, shared value' translated target: self action: #putOnBackground. stackSubMenu add: 'Background field, individual values' translated target: self action: #becomeSharedBackgroundField] ifFalse: [stackSubMenu add: 'put onto Background' translated target: self action: #putOnBackground]] ifTrue: [stackSubMenu add: 'remove from Background' translated target: self action: #putOnForeground. self couldHoldSeparateDataForEachInstance ifTrue: [self holdsSeparateDataForEachInstance ifFalse: [stackSubMenu add: 'start holding separate data for each instance' translated target: self action: #makeHoldSeparateDataForEachInstance] ifTrue: [stackSubMenu add: 'stop holding separate data for each instance' translated target: self action: #stopHoldingSeparateDataForEachInstance]. stackSubMenu add: 'be default value on new card' translated target: self action: #setAsDefaultValueForNewCard. (self hasProperty: #thumbnailImage) ifTrue: [stackSubMenu add: 'stop using for reference thumbnail' translated target: self action: #stopUsingForReferenceThumbnail] ifFalse: [stackSubMenu add: 'start using for reference thumbnail' translated target: self action: #startUsingForReferenceThumbnail]]]. stackSubMenu addLine]. (self isStackBackground) ifFalse: [stackSubMenu add: 'be a card in an existing stack...' translated action: #insertAsStackBackground]. stackSubMenu add: 'make an instance for my data' translated action: #abstractAModel. (self isStackBackground) ifFalse: [stackSubMenu add: 'become a stack of cards' translated action: #wrapWithAStack]. aMenu add: 'stacks and cards...' translated subMenu: stackSubMenu ! ! !Morph methodsFor: 'menus' stamp: 'nk 2/15/2004 08:19'! addStandardHaloMenuItemsTo: aMenu hand: aHandMorph "Add standard halo items to the menu" | unlockables | self isWorldMorph ifTrue: [^ self addWorldHaloMenuItemsTo: aMenu hand: aHandMorph]. self mustBeBackmost ifFalse: [aMenu add: 'send to back' translated action: #goBehind. aMenu add: 'bring to front' translated action: #comeToFront. self addEmbeddingMenuItemsTo: aMenu hand: aHandMorph. aMenu addLine]. self addFillStyleMenuItems: aMenu hand: aHandMorph. self addBorderStyleMenuItems: aMenu hand: aHandMorph. self addDropShadowMenuItems: aMenu hand: aHandMorph. self addLayoutMenuItems: aMenu hand: aHandMorph. self addHaloActionsTo: aMenu. owner isTextMorph ifTrue:[self addTextAnchorMenuItems: aMenu hand: aHandMorph]. aMenu addLine. self addToggleItemsToHaloMenu: aMenu. aMenu addLine. self addCopyItemsTo: aMenu. self addPlayerItemsTo: aMenu. self addExportMenuItems: aMenu hand: aHandMorph. self addStackItemsTo: aMenu. self addMiscExtrasTo: aMenu. Preferences noviceMode ifFalse: [self addDebuggingItemsTo: aMenu hand: aHandMorph]. aMenu addLine. aMenu defaultTarget: self. aMenu addLine. unlockables _ self submorphs select: [:m | m isLocked]. unlockables size == 1 ifTrue: [aMenu add: ('unlock "{1}"' translated format: unlockables first externalName) action: #unlockContents]. unlockables size > 1 ifTrue: [aMenu add: 'unlock all contents' translated action: #unlockContents. aMenu add: 'unlock...' translated action: #unlockOneSubpart]. aMenu defaultTarget: aHandMorph. ! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:22'! addToggleItemsToHaloMenu: aMenu "Add standard true/false-checkbox items to the memu" #( (resistsRemovalString toggleResistsRemoval 'whether I should be reistant to easy deletion via the pink X handle') (stickinessString toggleStickiness 'whether I should be resistant to a drag done by mousing down on me') (lockedString lockUnlockMorph 'when "locked", I am inert to all user interactions') (hasClipSubmorphsString changeClipSubmorphs 'whether the parts of objects within me that are outside my bounds should be masked.') (hasDirectionHandlesString changeDirectionHandles 'whether direction handles are shown with the halo') (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me') ) do: [:trip | aMenu addUpdating: trip first action: trip second. aMenu balloonTextForLastItem: trip third translated]. self couldHaveRoundedCorners ifTrue: [aMenu addUpdating: #roundedCornersString action: #toggleCornerRounding. aMenu balloonTextForLastItem: 'whether my corners should be rounded']! ! !Morph methodsFor: 'menus' stamp: 'dgd 10/17/2003 22:51'! adhereToEdge | menu | menu _ MenuMorph new defaultTarget: self. #(top right bottom left - center - topLeft topRight bottomRight bottomLeft - none) do: [:each | each == #- ifTrue: [menu addLine] ifFalse: [menu add: each asString translated selector: #setToAdhereToEdge: argument: each]]. menu popUpEvent: self currentEvent in: self world! ! !Morph methodsFor: 'menus' stamp: 'dgd 2/22/2003 14:26'! adhereToEdge: edgeSymbol (owner isNil or: [owner isHandMorph]) ifTrue: [^self]. self perform: (edgeSymbol , ':') asSymbol withArguments: (Array with: (owner perform: edgeSymbol))! ! !Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'! changeDirectionHandles ^self wantsDirectionHandles: self wantsDirectionHandles not! ! !Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 09:58'! chooseNewGraphicCoexisting: aBoolean "Allow the user to choose a different form for her form-based morph" | replacee aGraphicalMenu | aGraphicalMenu := GraphicalMenu new initializeFor: self withForms: self reasonableForms coexist: aBoolean. aBoolean ifTrue: [self primaryHand attachMorph: aGraphicalMenu] ifFalse: [replacee := self topRendererOrSelf. replacee owner replaceSubmorph: replacee by: aGraphicalMenu]! ! !Morph methodsFor: 'menus'! defaultArrowheadSize ^ self class defaultArrowheadSize! ! !Morph methodsFor: 'menus' stamp: 'dgd 10/8/2003 18:29'! dismissButton "Answer a button whose action would be to dismiss the receiver, and whose action is to send #delete to the receiver" | aButton | aButton _ SimpleButtonMorph new. aButton target: self topRendererOrSelf; color: Color tan; label: 'X' font: Preferences standardButtonFont; actionSelector: #delete; setBalloonText: 'dismiss' translated. ^ aButton! ! !Morph methodsFor: 'menus' stamp: 'ar 10/25/2000 23:17'! doMenuItem: menuString | aMenu anItem aNominalEvent aHand | aMenu _ self buildHandleMenu: (aHand _ self currentHand). aMenu allMorphsDo: [:m | m step]. "Get wordings current" anItem _ aMenu itemWithWording: menuString. anItem ifNil: [^ self player scriptingError: 'Menu item not found: ', menuString]. aNominalEvent _ MouseButtonEvent new setType: #mouseDown position: anItem bounds center which: 4 "red" buttons: 4 "red" hand: aHand stamp: nil. anItem invokeWithEvent: aNominalEvent! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:50'! exportAsBMP | fName | fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.bmp'. fName isEmpty ifTrue:[^self]. self imageForm writeBMPfileNamed: fName.! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:50'! exportAsGIF | fName | fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.gif'. fName isEmpty ifTrue:[^self]. GIFReadWriter putForm: self imageForm onFileNamed: fName.! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:51'! exportAsJPEG "Export the receiver's image as a JPEG" | fName | fName _ FillInTheBlank request: 'Please enter the name' translated initialAnswer: self externalName,'.jpeg'. fName isEmpty ifTrue: [^ self]. self imageForm writeJPEGfileNamed: fName! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 17:51'! exportAsPNG | fName | fName _ FillInTheBlank request:'Please enter the name' translated initialAnswer: self externalName,'.png'. fName isEmpty ifTrue:[^self]. PNGReadWriter putForm: self imageForm onFileNamed: fName.! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:23'! hasDirectionHandlesString ^ (self wantsDirectionHandles ifTrue: ['<on>'] ifFalse: ['<off>']) , 'direction handles' translated! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:24'! hasDragAndDropEnabledString "Answer a string to characterize the drag & drop status of the receiver" ^ (self dragNDropEnabled ifTrue: ['<on>'] ifFalse: ['<off>']) , 'accept drops' translated! ! !Morph methodsFor: 'menus' stamp: 'sw 12/8/2004 11:31'! helpButton "Answer a button whose action would be to put up help concerning the receiver" | aButton aForm | aButton _ IconicButton new target: self. aButton borderWidth: 0. (aForm _ ScriptingSystem formAtKey: #MagentaQuestionMark) ifNil: [aForm _ Form extent: 13@22 depth: 16 fromArray: #( 0 0 12017 787558129 0 0 0 0 12017 787577951 2086632543 787558129 0 0 0 787577951 2086632543 2086632543 2086632543 787546112 0 12017 2086632543 2086632543 2086632543 2086632543 2086612721 0 12017 2086632543 2086632543 2086632543 2086632543 2086612721 0 787577951 2086632543 2086632543 2086632543 2086632543 2086632543 787546112 787577951 2086632543 2086632543 2086632543 2086632543 2086632543 787546112 787577951 2086632543 65537 97375 2086632543 2086632543 787546112 787577951 2086600705 65537 65537 97375 2086632543 787546112 787577951 2086600705 97375 2086600705 97375 2086632543 787546112 787577951 2086632543 2086632543 2086600705 97375 2086632543 787546112 787577951 2086632543 2086600705 65537 2086632543 2086632543 787546112 787577951 2086632543 65537 2086632543 2086632543 2086632543 787546112 787577951 2086632543 2086632543 2086632543 2086632543 2086632543 787546112 787577951 2086632543 65537 2086632543 2086632543 2086632543 787546112 787577951 2086632543 65537 2086632543 2086632543 2086632543 787546112 787577951 2086632543 2086632543 2086632543 2086632543 2086632543 787546112 12017 2086632543 2086632543 2086632543 2086632543 2086612721 0 12017 2086632543 2086632543 2086632543 2086632543 2086612721 0 0 787577951 2086632543 2086632543 2086632543 787546112 0 0 12017 787577951 2086632543 787558129 0 0 0 0 12017 787558129 0 0 0) offset: 0@0. ScriptingSystem saveForm: aForm atKey: #MagentaQuestionMark]. aButton labelGraphic: aForm. aButton color: Color transparent; actWhen: #buttonUp; actionSelector: #presentHelp; setBalloonText: 'click here for help' translated. ^ aButton ! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:20'! lockedString "Answer the string to be shown in a menu to represent the 'locked' status" ^ (self isLocked ifTrue: ['<on>'] ifFalse: ['<off>']), 'be locked' translated! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:15'! maybeAddCollapseItemTo: aMenu "If appropriate, add a collapse item to the given menu" | anOwner | (anOwner _ self topRendererOrSelf owner) ifNotNil: [anOwner isWorldMorph ifTrue: [aMenu add: 'collapse' translated target: self action: #collapse]]! ! !Morph methodsFor: 'menus' stamp: 'sw 6/12/2001 21:08'! presentHelp "Present a help message if there is one available" self inform: 'Sorry, no help has been provided here yet.'! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 18:03'! printPSToFileNamed: aString "Ask the user for a filename and print this morph as postscript." | fileName rotateFlag psCanvasType psExtension | fileName := aString asFileName. psCanvasType _ PostscriptCanvas defaultCanvasType. psExtension _ psCanvasType defaultExtension. fileName := FillInTheBlank request: (String streamContents: [ :s | s nextPutAll: ('File name? ("{1}" will be added to end)' translated format: {psExtension})]) initialAnswer: fileName. fileName isEmpty ifTrue: [^ Beeper beep]. (fileName endsWith: psExtension) ifFalse: [fileName := fileName , psExtension]. rotateFlag := ((PopUpMenu labels: 'portrait (tall) landscape (wide)' translated) startUpWithCaption: 'Choose orientation...' translated) = 2. ((FileStream newFileNamed: fileName asFileName) converter: TextConverter defaultSystemConverter) nextPutAll: (psCanvasType morphAsPostscript: self rotated: rotateFlag); close! ! !Morph methodsFor: 'menus' stamp: 'dgd 9/5/2003 18:25'! putOnForeground "Place the receiver, formerly on the background, onto the foreground. If the receiver needs data carried on its behalf by the card, those data will be lost, so in this case get user confirmation before proceeding." self holdsSeparateDataForEachInstance "later add the refinement of not putting up the following confirmer if only a single instance of the current background's uniclass exists" ifTrue: [self confirm: 'Caution -- every card of this background formerly had its own value for this item. If you put it on the foreground, the values of this item on all other cards will be lost' translated orCancel: [^ self]]. self removeProperty: #shared. self stack reassessBackgroundShape. "still work to be done here!!"! ! !Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 22:42'! reasonableBitmapFillForms "Answer an OrderedCollection of forms that could be used to replace my bitmap fill, with my current form first." | reasonableForms myGraphic | reasonableForms := self class allSketchMorphForms. reasonableForms addAll: Imports default images. reasonableForms addAll: (BitmapFillStyle allSubInstances collect:[:f| f form]). reasonableForms remove: (myGraphic := self fillStyle form) ifAbsent: []. reasonableForms := reasonableForms asOrderedCollection. reasonableForms addFirst: myGraphic. ^reasonableForms! ! !Morph methodsFor: 'menus' stamp: 'nk 6/12/2004 09:55'! reasonableForms "Answer an OrderedCollection of forms that could be used to replace my form, with my current form first." | reasonableForms myGraphic | reasonableForms := self class allSketchMorphForms. reasonableForms addAll: Imports default images. reasonableForms remove: (myGraphic := self form) ifAbsent: []. reasonableForms := reasonableForms asOrderedCollection. reasonableForms addFirst: myGraphic. ^reasonableForms! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:18'! resistsRemovalString "Answer the string to be shown in a menu to represent the 'resistsRemoval' status" ^ (self resistsRemoval ifTrue: ['<on>'] ifFalse: ['<off>']), 'resist being deleted' translated! ! !Morph methodsFor: 'menus' stamp: 'yo 2/17/2005 16:58'! setArrowheads "Let the user edit the size of arrowheads for this object" | aParameter result | aParameter _ self renderedMorph valueOfProperty: #arrowSpec ifAbsent: [Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4]]. result _ Morph obtainArrowheadFor: 'Head size for arrowheads: ' translated defaultValue: aParameter asString. result ifNotNil: [self renderedMorph setProperty: #arrowSpec toValue: result] ifNil: [Beeper beep]! ! !Morph methodsFor: 'menus' stamp: 'dgd 8/30/2003 20:19'! stickinessString "Answer the string to be shown in a menu to represent the stickiness status" ^ (self isSticky ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'resist being picked up' translated! ! !Morph methodsFor: 'menus' stamp: 'sw 10/6/2004 12:16'! transferStateToRenderer: aRenderer "Transfer knownName, actorState, visible, and player info over to aRenderer, which is being imposed above me as a transformation shell" | current | (current _ self actorStateOrNil) ifNotNil: [aRenderer actorState: current. self actorState: nil]. (current _ self knownName) ifNotNil: [aRenderer setNameTo: current. self setNameTo: nil]. (current _ self player) ifNotNil: [aRenderer player: current. self player rawCostume: aRenderer. "NB player is redundantly pointed to in the extension of both the renderer and the rendee; this is regrettable but many years ago occasionally people tried to make that clean but always ran into problems iirc" "self player: nil"]. aRenderer simplySetVisible: self visible ! ! !Morph methodsFor: 'messenger' stamp: 'sw 11/3/2001 12:23'! affiliatedSelector "Answer a selector affiliated with the receiver for the purposes of launching a messenger. Reimplement this to plug into the messenger service" ^ nil! ! !Morph methodsFor: 'meta-actions' stamp: 'sw 7/22/2004 00:28'! addEmbeddingMenuItemsTo: aMenu hand: aHandMorph "Construct a menu offerring embed targets for the receiver. If the incoming menu is is not degenerate, add the constructed menu as a submenu; in any case, answer the embed-target menu" | menu | menu _ MenuMorph new defaultTarget: self. self potentialEmbeddingTargets reverseDo: [:m | menu add: (m knownName ifNil:[m class name asString]) target: m selector: #addMorphFrontFromWorldPosition: argumentList: {self topRendererOrSelf}]. aMenu ifNotNil: [menu submorphCount > 0 ifTrue:[aMenu add:'embed into' translated subMenu: menu]]. ^ menu! ! !Morph methodsFor: 'meta-actions' stamp: 'jcg 9/21/2001 13:22'! blueButtonDown: anEvent "Special gestures (cmd-mouse on the Macintosh; Alt-mouse on Windows and Unix) allow a mouse-sensitive morph to be moved or bring up a halo for the morph." | h tfm doNotDrag | h _ anEvent hand halo. "Prevent wrap around halo transfers originating from throwing the event back in" doNotDrag _ false. h ifNotNil:[ (h innerTarget == self) ifTrue:[doNotDrag _ true]. (h innerTarget hasOwner: self) ifTrue:[doNotDrag _ true]. (self hasOwner: h target) ifTrue:[doNotDrag _ true]]. tfm _ (self transformedFrom: nil) inverseTransformation. "cmd-drag on flexed morphs works better this way" h _ self addHalo: (anEvent transformedBy: tfm). doNotDrag ifTrue:[^self]. "Initiate drag transition if requested" anEvent hand waitForClicksOrDrag: h event: (anEvent transformedBy: tfm) selectors: { nil. nil. nil. #dragTarget:. } threshold: 5. "Pass focus explicitly here" anEvent hand newMouseFocus: h.! ! !Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 10:50'! buildHandleMenu: aHand "Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu." | menu | menu _ MenuMorph new defaultTarget: self. menu addStayUpItem. menu addLine. self addStandardHaloMenuItemsTo: menu hand: aHand. menu defaultTarget: aHand. self addAddHandMenuItemsForHalo: menu hand: aHand. menu defaultTarget: self. self addCustomHaloMenuItems: menu hand: aHand. menu defaultTarget: aHand. ^ menu ! ! !Morph methodsFor: 'meta-actions' stamp: 'dgd 11/15/2003 19:29'! buildMetaMenu: evt "Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph." | menu | menu _ MenuMorph new defaultTarget: self. menu addStayUpItem. menu add: 'grab' translated action: #grabMorph:. menu add: 'copy to paste buffer' translated action: #copyToPasteBuffer:. self maybeAddCollapseItemTo: menu. menu add: 'delete' translated action: #dismissMorph:. menu addLine. menu add: 'copy text' translated action: #clipText. menu add: 'copy Postscript' translated action: #clipPostscript. menu add: 'print Postscript to file...' translated action: #printPSToFile. menu addLine. menu add: 'go behind' translated action: #goBehind. menu add: 'add halo' translated action: #addHalo:. menu add: 'duplicate' translated action: #maybeDuplicateMorph:. self addEmbeddingMenuItemsTo: menu hand: evt hand. menu add: 'resize' translated action: #resizeMorph:. "Give the argument control over what should be done about fill styles" self addFillStyleMenuItems: menu hand: evt hand. self addDropShadowMenuItems: menu hand: evt hand. self addLayoutMenuItems: menu hand: evt hand. menu addUpdating: #hasClipSubmorphsString target: self selector: #changeClipSubmorphs argumentList: #(). menu addLine. (self morphsAt: evt position) size > 1 ifTrue: [menu add: 'submorphs...' translated target: self selector: #invokeMetaMenuAt:event: argument: evt position]. menu addLine. menu add: 'inspect' translated selector: #inspectAt:event: argument: evt position. menu add: 'explore' translated action: #explore. menu add: 'browse hierarchy' translated action: #browseHierarchy. menu add: 'make own subclass' translated action: #subclassMorph. menu addLine. menu add: 'set variable name...' translated action: #choosePartName. (self isMorphicModel) ifTrue: [menu add: 'save morph as prototype' translated action: #saveAsPrototype. (self ~~ self world modelOrNil) ifTrue: [menu add: 'become this world''s model' translated action: #beThisWorldsModel]]. menu add: 'save morph in file' translated action: #saveOnFile. (self hasProperty: #resourceFilePath) ifTrue: [((self valueOfProperty: #resourceFilePath) endsWith: '.morph') ifTrue: [menu add: 'save as resource' translated action: #saveAsResource]. menu add: 'update from resource' translated action: #updateFromResource] ifFalse: [menu add: 'attach to resource' translated action: #attachToResource]. menu add: 'show actions' translated action: #showActions. menu addLine. self addDebuggingItemsTo: menu hand: evt hand. self addCustomMenuItems: menu hand: evt hand. ^ menu ! ! !Morph methodsFor: 'meta-actions' stamp: 'yo 2/12/2005 15:25'! indicateAllSiblings "Indicate all the receiver and all its siblings by flashing momentarily." | aPlayer allBoxes | (aPlayer _ self topRendererOrSelf player) belongsToUniClass ifFalse: [^ self "error: 'not uniclass'"]. allBoxes _ aPlayer class allInstances select: [:m | m costume world == ActiveWorld] thenCollect: [:m | m costume boundsInWorld]. 5 timesRepeat: [Display flashAll: allBoxes andWait: 120]! ! !Morph methodsFor: 'meta-actions' stamp: 'sd 11/13/2003 21:28'! makeMultipleSiblings: evt "Make multiple siblings, first prompting the user for how many" | result | result _ FillInTheBlank request: 'how many siblings do you want?' translated initialAnswer: '2'. result isEmptyOrNil ifTrue: [^ self]. result first isDigit ifFalse: [^ Beeper beep]. self topRendererOrSelf makeSiblings: result asInteger.! ! !Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 08:12'! maybeDuplicateMorph "Maybe duplicate the morph" self okayToDuplicate ifTrue: [self duplicate openInHand]! ! !Morph methodsFor: 'meta-actions' stamp: 'RAA 3/8/2001 17:42'! openAButtonPropertySheet ButtonPropertiesMorph basicNew targetMorph: self; initialize; openNearTarget! ! !Morph methodsFor: 'meta-actions' stamp: 'RAA 2/19/2001 16:52'! openAPropertySheet ObjectPropertiesMorph basicNew targetMorph: self; initialize; openNearTarget! ! !Morph methodsFor: 'meta-actions' stamp: 'RAA 3/15/2001 12:56'! openATextPropertySheet "should only be sent to morphs that are actually supportive" TextPropertiesMorph basicNew targetMorph: self; initialize; openNearTarget! ! !Morph methodsFor: 'meta-actions' stamp: 'wiz 1/2/2005 01:06'! potentialEmbeddingTargets "Return the potential targets for embedding the receiver" | oneUp topRend | (oneUp _ (topRend _ self topRendererOrSelf) owner) ifNil:[^#()]. ^ (oneUp morphsAt: topRend referencePosition behind: topRend unlocked: true) select: [:m | m isFlexMorph not]! ! !Morph methodsFor: 'meta-actions' stamp: 'sw 11/27/2001 14:59'! resizeFromMenu "Commence an interaction that will resize the receiver" self resizeMorph: ActiveEvent! ! !Morph methodsFor: 'meta-actions' stamp: 'st 9/14/2004 12:30'! resizeMorph: evt | handle | handle _ HandleMorph new forEachPointDo: [:newPoint | self extent: (self griddedPoint: newPoint) - self bounds topLeft]. evt hand attachMorph: handle. handle startStepping. ! ! !Morph methodsFor: 'meta-actions'! showActions "Put up a message list browser of all the code that this morph would run for mouseUp, mouseDown, mouseMove, mouseEnter, mouseLeave, and mouseLinger. tk 9/13/97" | list cls selector adder | list _ SortedCollection new. adder _ [:mrClass :mrSel | list add: (MethodReference new setStandardClass: mrClass methodSymbol: mrSel)]. "the eventHandler" self eventHandler ifNotNil: [list _ self eventHandler methodRefList. (self eventHandler handlesMouseDown: nil) ifFalse: [adder value: HandMorph value: #grabMorph:]]. "If not those, then non-default raw events" #(#keyStroke: #mouseDown: #mouseEnter: #mouseLeave: #mouseMove: #mouseUp: #doButtonAction ) do: [:sel | cls _ self class whichClassIncludesSelector: sel. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: sel]]]. "The mechanism on a Button" (self respondsTo: #actionSelector) ifTrue: ["A button" selector _ self actionSelector. cls _ self target class whichClassIncludesSelector: selector. cls ifNotNil: ["want more than default behavior" cls == Morph ifFalse: [adder value: cls value: selector]]]. MessageSet openMessageList: list name: 'Actions of ' , self printString! ! !Morph methodsFor: 'miscellaneous' stamp: 'sw 7/20/2001 00:15'! setExtentFromHalo: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" self extent: anExtent! ! !Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'! name: aName (aName isString) ifTrue: [self setNameTo: aName]! ! !Morph methodsFor: 'naming' stamp: 'dgd 2/22/2003 14:33'! nameInModel "Return the name for this morph in the underlying model or nil." | w | w := self world. w isNil ifTrue: [^nil] ifFalse: [^w model nameFor: self]! ! !Morph methodsFor: 'naming' stamp: 'dgd 2/16/2003 21:57'! setNamePropertyTo: aName "change the receiver's externalName" self assureExtension externalName: aName! ! !Morph methodsFor: 'naming' stamp: 'yo 12/3/2004 17:02'! setNameTo: aName | nameToUse nameString | nameToUse := aName ifNotNil: [(nameString := aName asString) notEmpty ifTrue: [nameString] ifFalse: ['*']]. self setNamePropertyTo: nameToUse "no Texts here!!"! ! !Morph methodsFor: 'naming' stamp: 'gm 2/22/2003 13:16'! specialNameInModel "Return the name for this morph in the underlying model or nil." "Not an easy problem. For now, take the first part of the mouseDownSelector symbol in my eventHandler (fillBrushMouseUp:morph: gives 'fillBrush'). 5/26/97 tk" | hh | (self isMorphicModel) ifTrue: [^self slotName] ifFalse: [self eventHandler ifNotNil: [self eventHandler mouseDownSelector ifNotNil: [hh := self eventHandler mouseDownSelector indexOfSubCollection: 'Mouse' startingAt: 1. hh > 0 ifTrue: [^self eventHandler mouseDownSelector copyFrom: 1 to: hh - 1]]. self eventHandler mouseUpSelector ifNotNil: [hh := self eventHandler mouseUpSelector indexOfSubCollection: 'Mouse' startingAt: 1. hh > 0 ifTrue: [^self eventHandler mouseUpSelector copyFrom: 1 to: hh - 1]]]]. " (self eventHandler mouseDownRecipient respondsTo: #nameFor:) ifTrue: [ ^ self eventHandler mouseDownRecipient nameFor: self]]]. " "myModel _ self findA: MorphicModel. myModel ifNotNil: [^ myModel slotName]" ^self world specialNameInModelFor: self! ! !Morph methodsFor: 'object fileIn' stamp: 'dgd 2/22/2003 14:30'! convertAugust1998: varDict using: smartRefStrm "These variables are automatically stored into the new instance ('bounds' 'owner' 'submorphs' 'fullBounds' 'color' ). This method is for additional changes. Use statements like (foo _ varDict at: 'foo')." "Be sure to to fill in ('extension' ) and deal with the information in ('eventHandler' 'properties' 'costumee' )" "This method moves all property variables as well as eventHandler, and costumee into a morphicExtension." "Move refs to eventhandler and costumee into extension" | propVal | (varDict at: 'eventHandler') isNil ifFalse: [self eventHandler: (varDict at: 'eventHandler')]. (varDict at: 'costumee') isNil ifFalse: [self player: (varDict at: 'costumee')]. (varDict at: 'properties') isNil ifFalse: [(varDict at: 'properties') keys do: [:key | "Move property extensions into extension" propVal := (varDict at: 'properties') at: key. propVal ifNotNil: [key == #possessive ifTrue: [propVal == true ifTrue: [self bePossessive]] ifFalse: [key ifNotNil: [self assureExtension convertProperty: key toValue: propVal]]]]]! ! !Morph methodsFor: 'object fileIn' stamp: 'dgd 2/22/2003 14:30'! convertNovember2000DropShadow: varDict using: smartRefStrm "Work hard to eliminate the DropShadow. Inst vars are already stored into." | rend | submorphs notEmpty ifTrue: [rend := submorphs first renderedMorph. "a text?" rend setProperty: #hasDropShadow toValue: true. rend setProperty: #shadowColor toValue: (varDict at: 'color'). rend setProperty: #shadowOffset toValue: (varDict at: 'shadowOffset'). "ds owner ifNotNil: [ds owner addAllMorphs: ds submorphs]. ^rend does this" rend privateOwner: owner. self hasExtension ifTrue: ["" self extension actorState ifNotNil: [rend actorState: self extension actorState]. self extension externalName ifNotNil: [rend setNameTo: self extension externalName]. self extension player ifNotNil: ["" rend player: self extension player. self extension player rawCostume: rend]]. ^rend]. (rend := Morph new) color: Color transparent. ^rend! ! !Morph methodsFor: 'objects from disk' stamp: 'tk 11/26/2004 06:02'! convertToCurrentVersion: varDict refStream: smartRefStrm (varDict at: #ClassName) == #DropShadowMorph ifTrue: [ varDict at: #ClassName put: #Morph. "so we don't repeat this" ^ self convertNovember2000DropShadow: varDict using: smartRefStrm "always returns a new object of a different class" ]. varDict at: 'costumee' ifPresent: [ :x | self convertAugust1998: varDict using: smartRefStrm]. "never returns a different object" "5/18/2000" varDict at: 'openToDragNDrop' ifPresent: [ :x | self enableDragNDrop: x ]. ^super convertToCurrentVersion: varDict refStream: smartRefStrm. ! ! !Morph methodsFor: 'objects from disk' stamp: 'dgd 2/22/2003 14:33'! objectForDataStream: refStrm "I am being written out on an object file" | dp | self sqkPage ifNotNil: [refStrm rootObject == self | (refStrm rootObject == self sqkPage) ifFalse: [self url notEmpty ifTrue: [dp := self sqkPage copyForSaving. "be careful touching this object!!" refStrm replace: self with: dp. ^dp]]]. self prepareToBeSaved. "Amen" ^self! ! !Morph methodsFor: 'other' stamp: 'sw 10/30/2001 13:12'! removeAllButFirstSubmorph "Remove all of the receiver's submorphs other than the first one." self submorphs allButFirst do: [:m | m delete]! ! !Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:08'! menuButtonMouseEnter: event "The mouse entered a menu-button area; show the menu cursor temporarily" event hand showTemporaryCursor: Cursor menu! ! !Morph methodsFor: 'other events' stamp: 'sw 8/1/2001 14:09'! menuButtonMouseLeave: event "The mouse left a menu-button area; restore standard cursor" event hand showTemporaryCursor: nil! ! !Morph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 02:07'! initializeToStandAlone "Set up the receiver, created by a #basicNew and now ready to be initialized, as a fully-formed morph suitable for providing a graphic for a parts bin surrogate, and, when such a parts-bin surrogate is clicked on, for attaching to the hand as a viable stand-alone morph. Because of historical precedent, #initialize has been expected to handle this burden, though a great number of morphs actually cannot stand alone. In any case, by default we call the historical #initialize, though unhappily, so that all existing morphs will work no worse than before when using this protocol." self initialize! ! !Morph methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:37'! isPartsDonor "answer whether the receiver is PartsDonor" self hasExtension ifFalse: [^ false]. ^ self extension isPartsDonor! ! !Morph methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:39'! isPartsDonor: aBoolean "change the receiver's isPartDonor property" (self hasExtension not and: [aBoolean not]) ifTrue: [^ self]. self assureExtension isPartsDonor: aBoolean! ! !Morph methodsFor: 'pen' stamp: 'tak 1/17/2005 10:22'! addImageToPenTrails: aForm owner ifNil: [^ self]. owner addImageToPenTrails: aForm! ! !Morph methodsFor: 'pen' stamp: 'tak 1/17/2005 10:21'! stamp self addImageToPenTrails: self imageForm! ! !Morph methodsFor: 'pen' stamp: 'dgd 2/22/2003 14:36'! trailMorph "You can't draw trails on me, but try my owner." owner isNil ifTrue: [^nil]. ^owner trailMorph! ! !Morph methodsFor: 'player' stamp: 'tk 10/30/2001 12:13'! assuredCardPlayer "Answer the receiver's player, creating a new one if none currently exists" | aPlayer | (aPlayer _ self player) ifNotNil: [ (aPlayer isKindOf: CardPlayer) ifTrue: [^ aPlayer] ifFalse: [self error: 'Must convert to a CardPlayer'] "later convert using as: and remove the error"]. self assureExternalName. "a default may be given if not named yet" self player: (aPlayer _ UnscriptedCardPlayer newUserInstance). "Force it to be a CardPlayer. Morph class no longer dictates what kind of player" aPlayer costume: self. self presenter ifNotNil: [self presenter flushPlayerListCache]. ^ aPlayer! ! !Morph methodsFor: 'player' stamp: 'mir 6/13/2001 14:45'! shouldRememberCostumes ^true! ! !Morph methodsFor: 'player commands' stamp: 'nb 6/17/2003 12:25'! beep: soundName self playSoundNamed: soundName ! ! !Morph methodsFor: 'player commands' stamp: 'gk 2/23/2004 21:08'! playSoundNamed: soundName "Play the sound with the given name. Does nothing if this image lacks sound playing facilities." SoundService default playSoundNamed: soundName asString! ! !Morph methodsFor: 'player viewer' stamp: 'sw 8/3/2001 18:40'! openViewerForArgument "Open up a viewer for a player associated with the morph in question. Temporarily, if shift key is down, open up an instance browser on the morph itself, not the player, with tiles showing, instead" ActiveEvent shiftPressed ifTrue: [ActiveWorld abandonAllHalos. ^ self openInstanceBrowserWithTiles]. self presenter viewMorph: self! ! !Morph methodsFor: 'printing' stamp: 'bf 7/17/2003 12:53'! clipText "Copy the text in the receiver or in its submorphs to the clipboard" | content | "My own text" content _ self userString. "Or in my submorphs" content ifNil: [ | list | list _ self allStringsAfter: nil. list notEmpty ifTrue: [ content _ String streamContents: [:stream | list do: [:each | stream nextPutAll: each; cr]]]]. "Did we find something?" content ifNil: [self flash "provide feedback"] ifNotNil: [Clipboard clipboardText: content].! ! !Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 14:27'! colorString: aColor aColor isNil ifTrue: [^'nil']. Color colorNames do: [:colorName | aColor = (Color perform: colorName) ifTrue: [^'Color ' , colorName]]. ^aColor storeString! ! !Morph methodsFor: 'printing' stamp: 'RAA 2/26/2001 07:22'! morphReport ^self morphReportFor: #(hResizing vResizing bounds)! ! !Morph methodsFor: 'printing' stamp: 'RAA 2/25/2001 17:47'! morphReportFor: attributeList | s | s _ WriteStream on: String new. self morphReportFor: attributeList on: s indent: 0. StringHolder new contents: s contents; openLabel: 'morph report'! ! !Morph methodsFor: 'printing' stamp: 'RAA 2/25/2001 17:48'! morphReportFor: attributeList on: aStream indent: anInteger anInteger timesRepeat: [aStream tab]. aStream print: self; space. attributeList do: [ :a | aStream print: (self perform: a); space]. aStream cr. submorphs do: [ :sub | sub morphReportFor: attributeList on: aStream indent: anInteger + 1 ].! ! !Morph methodsFor: 'printing' stamp: 'dgd 2/22/2003 19:05'! printOn: aStream | aName | super printOn: aStream. (aName := self knownName) notNil ifTrue: [aStream nextPutAll: '<' , aName , '>']. aStream nextPutAll: '('. aStream print: self identityHash; nextPutAll: ')'! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:22'! addFlexShellIfNecessary "If this morph requires a flex shell to scale or rotate, then wrap it in one and return it. Polygons, eg, may override to return themselves." ^ self addFlexShell! ! !Morph methodsFor: 'rotate scale and flex' stamp: 'mu 3/29/2004 17:33'! removeFlexShell self isFlexed ifTrue: [self owner removeFlexShell]! ! !Morph methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:44'! cornerStyle: aSymbol aSymbol == #square ifTrue:[self removeProperty: #cornerStyle] ifFalse:[self setProperty: #cornerStyle toValue: aSymbol]. self changed! ! !Morph methodsFor: 'rounding' stamp: 'dgd 9/6/2003 18:27'! roundedCornersString "Answer the string to put in a menu that will invite the user to switch to the opposite corner-rounding mode" ^ (self wantsRoundedCorners ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'round corners' translated! ! !Morph methodsFor: 'rounding' stamp: 'ar 12/25/2001 19:44'! toggleCornerRounding self cornerStyle == #rounded ifTrue: [self cornerStyle: #square] ifFalse: [self cornerStyle: #rounded]. self changed! ! !Morph methodsFor: 'rounding' stamp: 'ar 12/22/2001 22:45'! wantsRoundedCorners "Return true if the receiver wants its corners rounded" ^ self cornerStyle == #rounded! ! !Morph methodsFor: 'scripting' stamp: 'dgd 7/4/2004 12:41'! arrowDeltaFor: aGetSelector "Answer a number indicating the default arrow delta to be used in a numeric readout with the given get-selector. This is a hook that subclasses of Morph can reimplement." aGetSelector == #getScaleFactor ifTrue: [^ 0.1]. ^ 1! ! !Morph methodsFor: 'scripting' stamp: 'sw 10/17/2001 09:46'! bringTileScriptingElementsUpToDate "Send #bringUpToDate to every tile-scripting element of the receiver, including possibly the receiver itself" (self allMorphs select: [:s | s isTileScriptingElement]) do: [:el | el bringUpToDate]! ! !Morph methodsFor: 'scripting' stamp: 'RAA 3/9/2001 11:39'! bringUpToDate (self buttonProperties ifNil: [^self]) bringUpToDate! ! !Morph methodsFor: 'scripting' stamp: 'sw 9/13/2002 16:46'! defaultFloatPrecisionFor: aGetSelector "Answer a number indicating the default float precision to be used in a numeric readout for which the receiver provides the data. Individual morphs can override this. Showing fractional values for readouts of getCursor was in response to an explicit request from ack" (self renderedMorph decimalPlacesForGetter: aGetSelector) ifNotNilDo: [:places | ^ (Utilities floatPrecisionForDecimalPlaces: places)]. (#(getCursor getNumericValue getNumberAtCursor getCursorWrapped getScaleFactor) includes: aGetSelector) ifTrue: [^ 0.01]. ^ 1! ! !Morph methodsFor: 'scripting' stamp: 'RAA 3/9/2001 11:47'! isTileScriptingElement ^ self hasButtonProperties and: [self buttonProperties isTileScriptingElement]! ! !Morph methodsFor: 'scripting' stamp: 'nk 8/21/2004 12:17'! triggerScript: aSymbol "Have my player perform the script of the given name, which is guaranteed to exist." ^self assuredPlayer triggerScript: aSymbol! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 17:04'! step "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The generic version dispatches control to the player, if any. The nasty circumlocation about owner's transformation is necessitated by the flexing problem that the player remains in the properties dictionary both of the flex and the real morph. In the current architecture, only the top renderer's pointer to the player should actually be honored for the purpose of firing." ! ! !Morph methodsFor: 'stepping and presenter' stamp: 'ar 2/12/2001 18:05'! stepAt: millisecondClockValue "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch. Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value" self player ifNotNilDo:[:p| p stepAt: millisecondClockValue]. self step ! ! !Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:11'! activeHand ^ActiveHand! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:05'! isInWorld "Return true if this morph is in a world." ^self world notNil! ! !Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:12'! outermostWorldMorph | outer | World ifNotNil:[^World]. self flag: #arNote. "stuff below is really only for MVC" outer _ self outermostMorphThat: [ :x | x isWorldMorph]. outer ifNotNil: [^outer]. self isWorldMorph ifTrue: [^self]. ^nil! ! !Morph methodsFor: 'structure' stamp: 'dgd 8/28/2004 18:43'! pasteUpMorphHandlingTabAmongFields "Answer the nearest PasteUpMorph in my owner chain that has the tabAmongFields property, or nil if none" | aPasteUp | aPasteUp _ self owner. [aPasteUp notNil] whileTrue: [aPasteUp tabAmongFields ifTrue: [^ aPasteUp]. aPasteUp _ aPasteUp owner]. ^ nil! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'! renderedMorph "If the receiver is a renderer morph, answer the rendered morph. Otherwise, answer the receiver. A renderer morph with no submorphs answers itself. See the comment in Morph>isRenderer." self isRenderer ifFalse: [^self]. submorphs isEmpty ifTrue: [^self]. ^self firstSubmorph renderedMorph! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:34'! root "Return the root of the composite morph containing the receiver. The owner of the root is either nil, a WorldMorph, or a HandMorph. If the receiver's owner is nil, the root is the receiver itself. This method always returns a morph." (owner isNil or: [owner isWorldOrHandMorph]) ifTrue: [^self]. ^owner root! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 19:06'! topRendererOrSelf "Answer the topmost renderer for this morph, or this morph itself if it has no renderer. See the comment in Morph>isRenderer." | top topsOwner | owner ifNil: [^self]. self isWorldMorph ifTrue: [^self]. "ignore scaling of this world" top := self. topsOwner := top owner. [topsOwner notNil and: [topsOwner isRenderer]] whileTrue: [top := topsOwner. topsOwner := top owner]. ^top! ! !Morph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:36'! world ^owner isNil ifTrue: [nil] ifFalse: [owner world]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 12:50'! allKnownNames "Return a list of all known names based on the scope of the receiver. Does not include the name of the receiver itself. Items in parts bins are excluded. Reimplementors (q.v.) can extend the list" ^ Array streamContents: [:s | self allSubmorphNamesDo: [:n | s nextPut: n]] ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:27'! allMorphsDo: aBlock "Evaluate the given block for all morphs in this composite morph (including the receiver)." submorphs do: [:m | m allMorphsDo: aBlock]. aBlock value: self! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 12:44'! allSubmorphNamesDo: nameBlock "Return a list of all known names of submorphs and nested submorphs of the receiver, based on the scope of the receiver. Items in parts bins are excluded" self isPartsBin ifTrue: [^ self]. "Don't report names from parts bins" self submorphsDo: [:m | m knownName ifNotNilDo: [:n | nameBlock value: n]. m allSubmorphNamesDo: nameBlock]. ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 3/17/2001 15:32'! findSubmorphBinary: aBlock "Use binary search for finding a specific submorph of the receiver. Caller must be certain that the ordering holds for the submorphs." ^submorphs findBinary: aBlock ifNone:[nil].! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:31'! firstSubmorph ^submorphs first! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! hasSubmorphs ^submorphs notEmpty! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! lastSubmorph ^submorphs last! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! morphsAt: aPoint behind: aMorph unlocked: aBool "Return all morphs at aPoint that are behind frontMorph; if aBool is true return only unlocked, visible morphs." | isBack found all tfm | all := (aMorph isNil or: [owner isNil]) ifTrue: ["Traverse down" (self fullBounds containsPoint: aPoint) ifFalse: [^#()]. (aBool and: [self isLocked or: [self visible not]]) ifTrue: [^#()]. nil] ifFalse: ["Traverse up" tfm := self transformedFrom: owner. all := owner morphsAt: (tfm localPointToGlobal: aPoint) behind: self unlocked: aBool. WriteStream with: all]. isBack := aMorph isNil. self submorphsDo: [:m | isBack ifTrue: [tfm := m transformedFrom: self. found := m morphsAt: (tfm globalPointToLocal: aPoint) behind: nil unlocked: aBool. found notEmpty ifTrue: [all ifNil: [all := WriteStream on: #()]. all nextPutAll: found]]. m == aMorph ifTrue: [isBack := true]]. (isBack and: [self containsPoint: aPoint]) ifTrue: [all ifNil: [^Array with: self]. all nextPut: self]. ^all ifNil: [#()] ifNotNil: [all contents]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle. someMorph is either an immediate child of the receiver or nil (in which case all submorphs of the receiver are enumerated)." self submorphsDo:[:m| m == someMorph ifTrue:["Try getting out quickly" owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. (m fullBoundsInWorld intersects: aRectangle) ifTrue:[aBlock value: m]]. owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! morphsInFrontOverlapping: aRectangle "Return all top-level morphs in front of someMorph that overlap with the given rectangle." | morphList | morphList _ WriteStream on: Array new. self morphsInFrontOf: nil overlapping: aRectangle do:[:m | morphList nextPut: m]. ^morphList contents! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 9/9/2000 17:31'! morphsInFrontOverlapping: aRectangle do: aBlock "Evaluate aBlock with all top-level morphs in front of someMorph that overlap with the given rectangle." ^self morphsInFrontOf: nil overlapping: aRectangle do: aBlock! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 8/13/2003 11:32'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph"! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'! shuffleSubmorphs "Randomly shuffle the order of my submorphs. Don't call this method lightly!!" | bg | self invalidRect: self fullBounds. (submorphs notEmpty and: [submorphs last mustBeBackmost]) ifTrue: [bg := submorphs last. bg privateDelete]. submorphs := submorphs shuffled. bg ifNotNil: [self addMorphBack: bg]. self layoutChanged! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'gm 2/22/2003 13:16'! submorphNamed: aName ifNone: aBlock "Find the first submorph with this name, or a button with an action selector of that name" | sub args | self submorphs do: [:p | p knownName = aName ifTrue: [^p]]. self submorphs do: [:button | (button respondsTo: #actionSelector) ifTrue: [button actionSelector == aName ifTrue: [^button]]. ((button respondsTo: #arguments) and: [(args := button arguments) notNil]) ifTrue: [(args at: 2 ifAbsent: [nil]) == aName ifTrue: [^button]]. (button isAlignmentMorph) ifTrue: [(sub := button submorphNamed: aName ifNone: [nil]) ifNotNil: [^sub]]]. ^aBlock value! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'! submorphsDo: aBlock submorphs do: aBlock! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/28/2001 08:39'! actWhen "Answer when the receiver, probably being used as a button, should have its action triggered" ^ self valueOfProperty: #actWhen ifAbsentPut: [#buttonDown]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 9/25/2001 10:23'! actWhen: aButtonPhase "Set the receiver's actWhen trait" self setProperty: #actWhen toValue: aButtonPhase! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28'! addAllMorphs: aCollection ^self privateAddAllMorphs: aCollection atIndex: submorphs size! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:29'! addAllMorphs: aCollection after: anotherMorph ^self privateAddAllMorphs: aCollection atIndex: (submorphs indexOf: anotherMorph ifAbsent: [submorphs size])! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 12/16/2001 21:08'! addMorphFrontFromWorldPosition: aMorph ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:26'! addMorphNearBack: aMorph | bg | (submorphs notEmpty and: [submorphs last mustBeBackmost]) ifTrue: [bg := submorphs last. bg privateDelete]. self addMorphBack: aMorph. bg ifNotNil: [self addMorphBack: bg]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'dgd 2/22/2003 14:30'! comeToFront | outerMorph | outerMorph := self topRendererOrSelf. (outerMorph owner isNil or: [outerMorph owner hasSubmorphs not]) ifTrue: [^self]. outerMorph owner firstSubmorph == outerMorph ifFalse: [outerMorph owner addMorphFront: outerMorph]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'BG 12/5/2003 22:31'! delete "Remove the receiver as a submorph of its owner and make its new owner be nil." | aWorld | aWorld := self world ifNil: [World]. "Terminate genie recognition focus" "I encountered a case where the hand was nil, so I put in a little protection - raa " " This happens when we are in an MVC project and open a morphic window. - BG " aWorld ifNotNil: [self disableSubmorphFocusForHand: self activeHand. self activeHand releaseKeyboardFocus: self; releaseMouseFocus: self.]. owner ifNotNil:[ self privateDelete. self player ifNotNilDo: [ :player | "Player must be notified" player noteDeletionOf: self fromWorld: aWorld]].! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/10/2003 18:31'! privateDelete "Remove the receiver as a submorph of its owner" owner ifNotNil:[owner removeMorph: self].! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:08'! removeAllMorphs | oldMorphs myWorld | myWorld _ self world. (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. submorphs do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. oldMorphs _ submorphs. submorphs _ EmptyArray. oldMorphs do: [ :m | self removedMorph: m ]. self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'nk 10/16/2003 14:02'! removeAllMorphsIn: aCollection "greatly speeds up the removal of *lots* of submorphs" | set myWorld | set _ IdentitySet new: aCollection size * 4 // 3. aCollection do: [:each | each owner == self ifTrue: [ set add: each]]. myWorld _ self world. (fullBounds notNil or:[myWorld notNil]) ifTrue:[self invalidRect: self fullBounds]. set do: [:m | myWorld ifNotNil: [ m outOfWorld: myWorld ]. m privateOwner: nil]. submorphs _ submorphs reject: [ :each | set includes: each]. set do: [ :m | self removedMorph: m ]. self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'di 10/18/2004 21:50'! removeMorph: aMorph "Remove the given morph from my submorphs" | aWorld | aMorph owner == self ifFalse:[^self]. aWorld := self world. aWorld ifNotNil:[ aMorph outOfWorld: aWorld. self privateInvalidateMorph: aMorph. ]. self privateRemove: aMorph. aMorph privateOwner: nil. self removedMorph: aMorph. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/12/2003 22:01'! removedMorph: aMorph "Notify the receiver that aMorph was just removed from its children" ! ! !Morph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:14'! canDrawBorder: aBorderStyle "Return true if the receiver can be drawn with the given border style." ^true! ! !Morph methodsFor: 'testing' stamp: 'nk 6/12/2004 09:17'! isSketchMorph ^self class isSketchMorphClass! ! !Morph methodsFor: 'testing' stamp: 'dgd 2/16/2003 21:20'! knownName "answer a name by which the receiver is known, or nil if none" ^ self hasExtension ifTrue: [self extension externalName]! ! !Morph methodsFor: 'testing' stamp: 'ar 12/3/2001 12:33'! shouldDropOnMouseUp | former | former _ self formerPosition ifNil:[^false]. ^(former dist: self position) > 10! ! !Morph methodsFor: 'testing' stamp: 'sw 10/24/2004 15:28'! wantsSteps "Return true if the receiver overrides the default Morph step method." "Details: Find first class in superclass chain that implements #step and return true if it isn't class Morph." | c | self isPartsDonor ifTrue: [^ false]. (self == self topRendererOrSelf) ifTrue: [self player wantsSteps ifTrue: [^ true]]. c _ self class. [c includesSelector: #step] whileFalse: [c _ c superclass]. ^ c ~= Morph! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/17/2001 12:45'! addTextAnchorMenuItems: topMenu hand: aHand | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addUpdating: #hasInlineAnchorString action: #changeInlineAnchor. aMenu addUpdating: #hasParagraphAnchorString action: #changeParagraphAnchor. aMenu addUpdating: #hasDocumentAnchorString action: #changeDocumentAnchor. topMenu ifNotNil:[topMenu add: 'text anchor' subMenu: aMenu]. ^aMenu! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:47'! changeDocumentAnchor "Change the anchor from/to document anchoring" | newType | newType := self textAnchorType == #document ifTrue: [#paragraph] ifFalse: [ #document]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! changeInlineAnchor "Change the anchor from/to line anchoring" | newType | newType := self textAnchorType == #inline ifTrue: [#paragraph] ifFalse: [#inline]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'text-anchor' stamp: 'aoy 2/15/2003 21:48'! changeParagraphAnchor "Change the anchor from/to paragraph anchoring" | newType | newType := self textAnchorType == #paragraph ifTrue: [#document] ifFalse: [#paragraph]. owner isTextMorph ifTrue: [owner anchorMorph: self at: self position type: newType]! ! !Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! hasDocumentAnchorString ^ (self textAnchorType == #document ifTrue: ['<on>'] ifFalse: ['<off>']) , 'Document' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! hasInlineAnchorString ^ (self textAnchorType == #inline ifTrue: ['<on>'] ifFalse: ['<off>']) , 'Inline' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'dgd 9/6/2003 18:14'! hasParagraphAnchorString ^ (self textAnchorType == #paragraph ifTrue: ['<on>'] ifFalse: ['<off>']) , 'Paragraph' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:47'! relativeTextAnchorPosition ^self valueOfProperty: #relativeTextAnchorPosition! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:22'! relativeTextAnchorPosition: aPoint ^self setProperty: #relativeTextAnchorPosition toValue: aPoint! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:36'! textAnchorType ^self valueOfProperty: #textAnchorType ifAbsent:[#document]! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:37'! textAnchorType: aSymbol aSymbol == #document ifTrue:[^self removeProperty: #textAnchorType] ifFalse:[^self setProperty: #textAnchorType toValue: aSymbol].! ! !Morph methodsFor: 'texture support' stamp: 'dgd 2/16/2003 20:02'! isValidWonderlandTexture "Return true if the receiver is a valid wonderland texture" ^ self valueOfProperty: #isValidWonderlandTexture ifAbsent: [true]! ! !Morph methodsFor: 'texture support' stamp: 'dgd 2/16/2003 20:03'! wonderlandTexture "Return the current wonderland texture associated with the receiver" ^ self valueOfProperty: #wonderlandTexture ifAbsent: []! ! !Morph methodsFor: 'texture support' stamp: 'dgd 2/22/2003 14:36'! wonderlandTexture: aTexture "Return the current wonderland texture associated with the receiver" aTexture isNil ifTrue: [self removeProperty: #wonderlandTexture] ifFalse: [self setProperty: #wonderlandTexture toValue: aTexture]! ! !Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 20:19'! icon "Answer a form with an icon to represent the receiver" ^ nil! ! !Morph methodsFor: 'thumbnail' stamp: 'dgd 9/12/2004 20:33'! iconOrThumbnail "Answer an appropiate form to represent the receiver" ^ self icon ifNil: [ | maxExtent fb |maxExtent := 320 @ 240. fb := self fullBounds. fb area <= (maxExtent x * maxExtent y) ifTrue: [self imageForm] ifFalse: [self imageFormForRectangle: (fb topLeft extent: maxExtent)] ] ! ! !Morph methodsFor: 'translation' stamp: 'sw 3/7/2004 13:03'! isPlayer: aPlayer ofReferencingTile: tile "Answer whether the given player is the object referred to by the given tile, or a sibling of that object. This theoretically is only sent to PhraseTileMorphs, so this version is theoretically never reached" ^ false! ! !Morph methodsFor: 'translation' stamp: 'yo 1/18/2004 10:31'! traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName "Traverse my submorphs, translating submorphs appropriately given the slot rename" submorphs do: [:tile | (tile isKindOf: AssignmentTileMorph) ifTrue: [tile assignmentRoot = oldSlotName ifTrue: [(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue: [tile setRoot: newSlotName]]]. (tile isMemberOf: TileMorph) ifTrue: [(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue: [(self isPlayer: aPlayer ofReferencingTile: tile) ifTrue: [tile setOperator: (Utilities getterSelectorFor: newSlotName)]]]. tile traverseRowTranslateSlotOld: oldSlotName of: aPlayer to: newSlotName]! ! !Morph methodsFor: 'translation' stamp: 'yo 1/18/2004 10:32'! traverseRowTranslateSlotOld: oldSlotName to: newSlotName "Traverse my submorphs, translating submorphs appropriately given the slot rename" submorphs do: [:tile | (tile isKindOf: AssignmentTileMorph) ifTrue: [tile assignmentRoot = oldSlotName ifTrue: [tile setRoot: newSlotName]]. (tile isMemberOf: TileMorph) ifTrue: [(tile operatorOrExpression = (Utilities getterSelectorFor: oldSlotName)) ifTrue: [tile setOperator: (Utilities getterSelectorFor: newSlotName)]]. tile traverseRowTranslateSlotOld: oldSlotName to: newSlotName]! ! !Morph methodsFor: 'undo' stamp: 'md 10/22/2003 15:56'! undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor "Handle undo and redo of move commands in morphic" self owner ifNil: [^Beeper beep]. redo ifFalse: ["undo sets up the redo state first" cmd redoTarget: self selector: #undoMove:redo:owner:bounds:predecessor: arguments: { cmd. true. owner. bounds. owner morphPreceding: self}]. formerOwner ifNotNil: [formerPredecessor ifNil: [formerOwner addMorphFront: self] ifNotNil: [formerOwner addMorph: self after: formerPredecessor]]. self bounds: formerBounds. (self isSystemWindow) ifTrue: [self activate]! ! !Morph methodsFor: 'updating' stamp: 'ar 6/25/2001 19:46'! changed "Report that the area occupied by this morph should be redrawn." ^fullBounds ifNil:[self invalidRect: self outerBounds] ifNotNil:[self invalidRect: fullBounds]! ! !Morph methodsFor: 'visual properties' stamp: 'ar 12/22/2001 22:44'! cornerStyle ^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! ! !Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:56'! defaultBitmapFillForm ^ImageMorph defaultForm. ! ! !Morph methodsFor: 'visual properties' stamp: 'dgd 2/16/2003 20:02'! fillStyle "Return the current fillStyle of the receiver." ^ self valueOfProperty: #fillStyle ifAbsent: ["Workaround already converted morphs" color ifNil: [self defaultColor]]! ! !Morph methodsFor: 'visual properties' stamp: 'nk 8/28/2003 15:57'! useBitmapFill "Make receiver use a solid fill style (e.g., a simple color)" | fill | self fillStyle isBitmapFill ifTrue:[^self]. "Already done" fill _ BitmapFillStyle fromForm: self defaultBitmapFillForm. "Note: Must fix the origin due to global coordinates" fill origin: self bounds origin. self fillStyle: fill.! ! !Morph methodsFor: 'visual properties' stamp: 'nk 2/27/2003 11:48'! useGradientFill "Make receiver use a solid fill style (e.g., a simple color)" | fill color1 color2 | self fillStyle isGradientFill ifTrue:[^self]. "Already done" color1 _ self color asColor. color2 _ color1 negated. fill _ GradientFillStyle ramp: {0.0 -> color1. 1.0 -> color2}. fill origin: self topLeft. fill direction: 0 @ self bounds extent y. fill normal: self bounds extent x @ 0. fill radial: false. self fillStyle: fill! ! !Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'! privateAddAllMorphs: aCollection atIndex: index "Private. Add aCollection of morphs to the receiver" | myWorld itsWorld otherSubmorphs | myWorld _ self world. otherSubmorphs _ submorphs copyWithoutAll: aCollection. (index between: 0 and: otherSubmorphs size) ifFalse: [^ self error: 'index out of range']. index = 0 ifTrue:[ submorphs _ aCollection asArray, otherSubmorphs] ifFalse:[ index = otherSubmorphs size ifTrue:[ submorphs _ otherSubmorphs, aCollection] ifFalse:[ submorphs _ otherSubmorphs copyReplaceFrom: index + 1 to: index with: aCollection ]]. aCollection do: [:m | | itsOwner | itsOwner _ m owner. itsOwner ifNotNil: [ itsWorld _ m world. (itsWorld == myWorld) ifFalse: [ itsWorld ifNotNil: [self privateInvalidateMorph: m]. m outOfWorld: itsWorld]. (itsOwner ~~ self) ifTrue: [ m owner privateRemove: m. m owner removedMorph: m ]]. m privateOwner: self. myWorld ifNotNil: [self privateInvalidateMorph: m]. (myWorld == itsWorld) ifFalse: [m intoWorld: myWorld]. itsOwner == self ifFalse: [ self addedMorph: m. m noteNewOwner: self ]. ]. self layoutChanged. ! ! !Morph methodsFor: 'private' stamp: 'nk 10/11/2003 16:08'! privateAddMorph: aMorph atIndex: index | oldIndex myWorld itsWorld oldOwner | ((index >= 1) and: [index <= (submorphs size + 1)]) ifFalse: [^ self error: 'index out of range']. myWorld _ self world. oldOwner _ aMorph owner. (oldOwner == self and: [(oldIndex _ submorphs indexOf: aMorph) > 0]) ifTrue:[ "aMorph's position changes within in the submorph chain" oldIndex < index ifTrue:[ "moving aMorph to back" submorphs replaceFrom: oldIndex to: index-2 with: submorphs startingAt: oldIndex+1. submorphs at: index-1 put: aMorph. ] ifFalse:[ "moving aMorph to front" oldIndex-1 to: index by: -1 do:[:i| submorphs at: i+1 put: (submorphs at: i)]. submorphs at: index put: aMorph. ]. ] ifFalse:[ "adding a new morph" oldOwner ifNotNil:[ itsWorld _ aMorph world. itsWorld ifNotNil: [self privateInvalidateMorph: aMorph]. (itsWorld == myWorld) ifFalse: [aMorph outOfWorld: itsWorld]. oldOwner privateRemove: aMorph. oldOwner removedMorph: aMorph. ]. aMorph privateOwner: self. submorphs _ submorphs copyReplaceFrom: index to: index-1 with: (Array with: aMorph). (itsWorld == myWorld) ifFalse: [aMorph intoWorld: myWorld]. ]. myWorld ifNotNil:[self privateInvalidateMorph: aMorph]. self layoutChanged. oldOwner == self ifFalse: [ self addedMorph: aMorph. aMorph noteNewOwner: self ]. ! ! !Morph methodsFor: 'private' stamp: 'ar 12/16/2001 21:47'! privateFullMoveBy: delta "Private!! Relocate me and all of my subMorphs by recursion. Subclasses that implement different coordinate systems may override this method." self privateMoveBy: delta. 1 to: submorphs size do: [:i | (submorphs at: i) privateFullMoveBy: delta]. owner ifNotNil:[ owner isTextMorph ifTrue:[owner adjustTextAnchor: self]].! ! !Morph methodsFor: 'private' stamp: 'dgd 2/16/2003 19:53'! privateMoveBy: delta "Private!! Use 'position:' instead." | fill | self hasExtension ifTrue: [self extension player ifNotNil: ["Most cases eliminated fast by above test" self getPenDown ifTrue: ["If this is a costume for a player with its pen down, draw a line." self moveWithPenDownBy: delta]]]. bounds _ bounds translateBy: delta. fullBounds ifNotNil: [fullBounds _ fullBounds translateBy: delta]. fill _ self fillStyle. fill isOrientedFill ifTrue: [fill origin: fill origin + delta]! ! !Morph methodsFor: 'private' stamp: 'di 10/18/2004 21:49'! privateRemove: aMorph "Private!! Should only be used by methods that maintain the ower/submorph invariant." submorphs _ submorphs copyWithout: aMorph. self layoutChanged.! ! !Morph methodsFor: 'private' stamp: 'md 12/12/2003 17:02'! privateRemoveMorph: aMorph self deprecated: 'Use #removeMorph: instead.'. ^self removeMorph: aMorph! ! !Morph methodsFor: '*connectors-scripting' stamp: 'nk 8/21/2004 08:39'! wantsConnectionVocabulary submorphs ifNil: [ ^true ]. "called from EToyVocabulary>>initialize after basicNew" ^ (Preferences valueOfFlag: #alwaysShowConnectionVocabulary) or: [ self connections isEmpty not ]! ! !Morph methodsFor: '*connectors-scripting' stamp: 'nk 9/10/2004 11:37'! wantsConnectorVocabulary "Answer true if I want to show a 'connector' vocabulary" ^false! ! !Morph methodsFor: 'scripting-override' stamp: 'nk 8/21/2004 13:28'! filterViewerCategoryDictionary: dict "dict has keys of categories and values of priority. You can re-order or remove categories here." Preferences eToyFriendly ifTrue: [dict removeKey: #layout].! ! !Morph methodsFor: 'latter day support' stamp: 'sw 1/6/2005 01:26'! isEtoyReadout "Answer whether the receiver can serve as an etoy readout" ^ false! ! !Morph commentStamp: 'efc 2/26/2003 20:01' prior: 0! A Morph (from the Greek "shape" or "form") is an interactive graphical object. General information on the Morphic system can be found at http://minnow.cc.gatech.edu/squeak/30. Morphs exist in a tree, rooted at a World (generally a PasteUpMorph). The morphs owned by a morph are its submorphs. Morphs are drawn recursively; if a Morph has no owner it never gets drawn. To hide a Morph and its submorphs, set its #visible property to false using the #visible: method. The World (screen) coordinate system is used for most coordinates, but can be changed if there is a TransformMorph somewhere in the owner chain. My instance variables have accessor methods (e.g., #bounds, #bounds:). Most users should use the accessor methods instead of using the instance variables directly. Structure: instance var Type Description bounds Rectangle A Rectangle indicating my position and a size that will enclose me. owner Morph My parent Morph, or nil for the top-level Morph, which is a or nil world, typically a PasteUpMorph. submorphs Array My child Morphs. fullBounds Rectangle A Rectangle minimally enclosing me and my submorphs. color Color My primary color. Subclasses can use this in different ways. extension MorphExtension Allows extra properties to be stored without adding a or nil storage burden to all morphs. By default, Morphs do not position their submorphs. Morphs may position their submorphs directly or use a LayoutPolicy to automatically control their submorph positioning. Although Morph has some support for BorderStyle, most users should use BorderedMorph if they want borders.! ]style[(2 5 130 37 59 12 325 14 209 12 2 4 4 11 1 11 9 90 5 123 5 35 9 66 5 78 14 209 12 91 11 24 13 22)f1,f1LMorph Hierarchy;,f1,f1Rhttp://minnow.cc.gatech.edu/squeak/30;,f1,f1LPasteUpMorph Comment;,f1,f1LTransformMorph Comment;,f1,f1u,f1,f1u,f1,f1u,f1i,f1,f1LRectangle Comment;,f1,f1LMorph Comment;,f1,f1LArray Comment;,f1,f1LRectangle Comment;,f1,f1LColor Comment;,f1,f1LMorphExtension Comment;,f1,f1LLayoutPolicy Comment;,f1,f1LBorderStyle Comment;,f1,f1LBorderedMorph Comment;,f1! !Morph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:43'! initialize "Morph initialize" "this empty array object is shared by all morphs with no submorphs:" EmptyArray _ Array new. FileList registerFileReader: self! ! !Morph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:54'! fileReaderServicesForFile: fullName suffix: suffix ^({ 'morph'. 'morphs'. 'sp'. '*' } includes: suffix) ifTrue: [ {SimpleServiceEntry provider: self label: 'load as morph' selector: #fromFileName: description: 'load as morph'}] ifFalse: [#()]! ! !Morph class methodsFor: 'fileIn/Out' stamp: 'yo 8/7/2003 11:02'! fromFileName: fullName "Reconstitute a Morph from the file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world" | aFileStream morphOrList | aFileStream _ (MultiByteBinaryOrTextStream with: ((FileStream readOnlyFileNamed: fullName) binary contentsOfEntireFile)) binary reset. morphOrList _ aFileStream fileInObjectAndCode. (morphOrList isKindOf: SqueakPage) ifTrue: [morphOrList _ morphOrList contentsMorph]. Smalltalk isMorphic ifTrue: [ActiveWorld addMorphsAndModel: morphOrList] ifFalse: [morphOrList isMorph ifFalse: [self inform: 'Can only load a single morph into an mvc project via this mechanism.']. morphOrList openInWorld]! ! !Morph class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 02:43'! serviceLoadMorphFromFile "Answer a service for loading a .morph file" ^ SimpleServiceEntry provider: self label: 'load as morph' selector: #fromFileName: description: 'load as morph' buttonLabel: 'load'! ! !Morph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 21:45'! services ^ Array with: self serviceLoadMorphFromFile! ! !Morph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'! unload FileList unregisterFileReader: self ! ! !Morph class methodsFor: 'instance creation' stamp: 'efo 5/3/2002 14:59'! initializedInstance "Answer an instance of the receiver which in some sense is initialized. In the case of Morphs, this will yield an instance that can be attached to the Hand after having received the same kind of basic initialization that would be obtained from an instance chosen from the 'new morph' menu. Return nil if the receiver is reluctant for some reason to return such a thing" ^ (self class includesSelector: #descriptionForPartsBin) ifTrue: [self newStandAlone] ifFalse: [self new]! ! !Morph class methodsFor: 'new-morph participation' stamp: 'sw 11/27/2001 13:20'! addPartsDescriptorQuadsTo: aList if: aBlock "For each of the standard objects to be put into parts bins based on declarations in this class, add a parts-launching quintuplet to aList, provided that the boolean-valued-block-with-one-argument supplied evaluates to true when provided the DescriptionForPartsBin" | info more | (self class includesSelector: #descriptionForPartsBin) ifTrue: [info _ self descriptionForPartsBin. (aBlock value: info) ifTrue: [aList add: {info globalReceiverSymbol. info nativitySelector. info formalName. info documentation. info sampleImageFormOrNil}]]. (self class includesSelector: #supplementaryPartsDescriptions) ifTrue: [more _ self supplementaryPartsDescriptions. (more isKindOf: DescriptionForPartsBin) ifTrue: [more _ Array with: more]. "The above being a mild bit of forgiveness, so that in the usual only-one case, the user need not return a collection" more do: [:aPartsDescription | (aBlock value: aPartsDescription) ifTrue: [aList add: {aPartsDescription globalReceiverSymbol. aPartsDescription nativitySelector. aPartsDescription formalName. aPartsDescription documentation. aPartsDescription sampleImageFormOrNil}]]]! ! !Morph class methodsFor: 'new-morph participation' stamp: 'sw 6/28/2001 11:33'! newStandAlone "Answer an instance capable of standing by itself as a usable morph." ^ self basicNew initializeToStandAlone! ! !Morph class methodsFor: 'new-morph participation' stamp: 'sw 8/2/2001 12:01'! partName: aName categories: aList documentation: aDoc "Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided" ^ DescriptionForPartsBin new formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: self name nativitySelector: #newStandAlone! ! !Morph class methodsFor: 'new-morph participation' stamp: 'sw 10/24/2001 15:51'! partName: aName categories: aList documentation: aDoc sampleImageForm: aForm "Answer a DescriptionForPartsBin which will represent a launch of a new instance of my class via the #newStandAlone protocol sent to my class. Use the category-list and documentation provided. This variant allows an overriding image form to be provided, useful in cases where we don't want to launch a sample instance just to get the form" | descr | descr _ DescriptionForPartsBin new formalName: aName categoryList: aList documentation: aDoc globalReceiverSymbol: self name nativitySelector: #newStandAlone. descr sampleImageForm: aForm. ^ descr ! ! !Morph class methodsFor: 'parts bin' stamp: 'sw 8/12/2001 14:26'! supplementaryPartsDescriptions "Answer a list of DescriptionForPartsBin objects that characterize objects that this class wishes to contribute to Stationery bins *other* than by the standard default #newStandAlone protocol" ^ { DescriptionForPartsBin formalName: 'Status' categoryList: #(Scripting) documentation: 'Buttons to run, stop, or single-step scripts' globalReceiverSymbol: #ScriptingSystem nativitySelector: #scriptControlButtons. DescriptionForPartsBin formalName: 'Scripting' categoryList: #(Scripting) documentation: 'A confined place for drawing and scripting, with its own private stop/step/go buttons.' globalReceiverSymbol: #ScriptingSystem nativitySelector: #newScriptingSpace. DescriptionForPartsBin formalName: 'Random' categoryList: #(Scripting) documentation: 'A tile that will produce a random number in a given range' globalReceiverSymbol: #RandomNumberTile nativitySelector: #new. DescriptionForPartsBin formalName: 'ButtonDown?' categoryList: #(Scripting) documentation: 'Tiles for querying whether the mouse button is down' globalReceiverSymbol: #ScriptingSystem nativitySelector: #anyButtonPressedTiles. DescriptionForPartsBin formalName: 'ButtonUp?' categoryList: #(Scripting) documentation: 'Tiles for querying whether the mouse button is up' globalReceiverSymbol: #ScriptingSystem nativitySelector: #noButtonPressedTiles. DescriptionForPartsBin formalName: 'NextPage' categoryList: #(Presentation) documentation: 'A button which, when clicked, takes the reader to the next page of a book' globalReceiverSymbol: #BookMorph nativitySelector: #nextPageButton. DescriptionForPartsBin formalName: 'PreviousPage' categoryList: #(Presentation) documentation: 'A button which, when clicked, takes the reader to the next page of a book' globalReceiverSymbol: #BookMorph nativitySelector: #previousPageButton.}, (Flaps quadsDefiningToolsFlap collect: [:aQuad | DescriptionForPartsBin fromQuad: aQuad categoryList: #(Tools)])! ! !Morph class methodsFor: 'scripting' stamp: 'sw 9/27/2001 17:40'! additionsToViewerCategoryBasic "Answer viewer additions for the 'basic' category" ^#( basic ( (slot x 'The x coordinate' Number readWrite Player getX Player setX:) (slot y 'The y coordinate' Number readWrite Player getY Player setY:) (slot heading 'Which direction the object is facing. 0 is straight up' Number readWrite Player getHeading Player setHeading:) (command forward: 'Moves the object forward in the direction it is heading' Number) (command turn: 'Change the heading of the object by the specified amount' Number) (command beep: 'Make the specified sound' Sound) ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'yo 8/2/2004 16:45'! additionsToViewerCategoryColorAndBorder "Answer viewer additions for the 'color & border' category" ^#( #'color & border' ( (slot color 'The color of the object' Color readWrite Player getColor Player setColor:) (slot borderStyle 'The style of the object''s border' BorderStyle readWrite Player getBorderStyle player setBorderStyle:) (slot borderColor 'The color of the object''s border' Color readWrite Player getBorderColor Player setBorderColor:) (slot borderWidth 'The width of the object''s border' Number readWrite Player getBorderWidth Player setBorderWidth:) (slot roundedCorners 'Whether corners should be rounded' Boolean readWrite Player getRoundedCorners Player setRoundedCorners:) (slot gradientFill 'Whether a gradient fill should be used' Boolean readWrite Player getUseGradientFill Player setUseGradientFill:) (slot secondColor 'The second color used when gradientFill is in effect' Color readWrite Player getSecondColor Player setSecondColor:) (slot radialFill 'Whether the gradient fill, if used, should be radial' Boolean readWrite Player getRadialGradientFill Player setRadialGradientFill:) (slot dropShadow 'Whether a drop shadow is shown' Boolean readWrite Player getDropShadow Player setDropShadow:) (slot shadowColor 'The color of the drop shadow' Color readWrite Player getShadowColor Player setShadowColor:) ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 4/20/2002 00:47'! additionsToViewerCategoryDragAndDrop "Answer viewer additions for the 'drag & drop' category" ^#( #'drag & drop' ( (slot 'drop enabled' 'Whether drop is enabled' Boolean readWrite Player getDropEnabled Player setDropEnabled:) (slot 'resist being picked up' 'Whether a simple mouse-drag on this object should allow it to be picked up' Boolean readWrite Player getSticky Player setSticky:) (slot 'resist deletion' 'Whether this is resistant to easy removal via the pink X halo handle.' Boolean readWrite Player getResistsRemoval Player setResistsRemoval:) (slot 'be locked' 'Whether this object should be blind to all input' Boolean readWrite Player getIsLocked Player setIsLocked:) ))! ! !Morph class methodsFor: 'scripting' stamp: 'sw 9/17/2002 13:58'! additionsToViewerCategoryGeometry "answer additions to the geometry viewer category" ^ #(geometry ( (slot x 'The x coordinate' Number readWrite Player getX Player setX:) (slot y 'The y coordinate' Number readWrite Player getY Player setY:) (slot heading 'Which direction the object is facing. 0 is straight up' Number readWrite Player getHeading Player setHeading:) (slot scaleFactor 'The factor by which the object is magnified' Number readWrite Player getScaleFactor Player setScaleFactor:) (slot left 'The left edge' Number readWrite Player getLeft Player setLeft:) (slot right 'The right edge' Number readWrite Player getRight Player setRight:) (slot top 'The top edge' Number readWrite Player getTop Player setTop:) (slot bottom 'The bottom edge' Number readWrite Player getBottom Player setBottom:) (slot length 'The length' Number readWrite Player getLength Player setLength:) (slot width 'The width' Number readWrite Player getWidth Player setWidth:) (slot headingTheta 'The angle, in degrees, that my heading vector makes with the positive x-axis' Number readWrite Player getHeadingTheta Player setHeadingTheta:) (slot distance 'The length of the vector connecting the origin to the object''s position' Number readWrite Player getDistance Player setDistance:) (slot theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position' Number readWrite Player getTheta Player setTheta: ) ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 11/16/2001 10:21'! additionsToViewerCategoryLayout "Answer viewer additions for the 'layout' category" ^#( layout ( (slot clipSubmorphs 'Whether or not to clip my submorphs' Boolean readWrite Player getClipSubmorphs Player setClipSubmorphs:) )) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 7/8/2004 00:20'! additionsToViewerCategoryMiscellaneous "Answer viewer additions for the 'miscellaneous' category" ^#( miscellaneous ( (command doMenuItem: 'do the menu item' Menu) (command show 'make the object visible') (command hide 'make the object invisible') (command wearCostumeOf: 'wear the costume of...' Player) (command fire 'trigger any and all of this object''s button actions') (slot copy 'returns a copy of this object' Player readOnly Player getNewClone unused unused) (slot elementNumber 'my index in my container' Number readWrite Player getIndexInOwner Player setIndexInOwner:) (slot holder 'the object''s container' Player readOnly Player getHolder Player setHolder:) (command stamp 'add my image to the pen trails') (command erase 'remove this object from the screen') (command stampAndErase 'add my image to the pen trails and go away') ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'dgd 8/8/2003 22:17'! additionsToViewerCategoryMotion "Answer viewer additions for the 'motion' category" ^#( motion ( (slot x 'The x coordinate' Number readWrite Player getX Player setX:) (slot y 'The y coordinate' Number readWrite Player getY Player setY:) (slot heading 'Which direction the object is facing. 0 is straight up' Number readWrite Player getHeading Player setHeading:) (command forward: 'Moves the object forward in the direction it is heading' Number) (slot obtrudes 'whether the object sticks out over its container''s edge' Boolean readOnly Player getObtrudes unused unused) (command turnToward: 'turn toward the given object' Player) (command moveToward: 'move toward the given object' Player) (command turn: 'Change the heading of the object by the specified amount' Number) (command bounce: 'bounce off the edge if hit' Sound) (command wrap 'wrap off the edge if appropriate') (command followPath 'follow the yellow brick road') (command goToRightOf: 'place this object to the right of another' Player) ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 12/9/2001 23:26'! additionsToViewerCategoryObservation "Answer viewer additions for the 'observations' category" ^#( observation ( (slot colorUnder 'The color under the center of the object' Color readOnly Player getColorUnder unused unused ) (slot brightnessUnder 'The brightness under the center of the object' Number readOnly Player getBrightnessUnder unused unused) (slot luminanceUnder 'The luminance under the center of the object' Number readOnly Player getLuminanceUnder unused unused) (slot saturationUnder 'The saturation under the center of the object' Number readOnly Player getSaturationUnder unused unused) )) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 4/17/2003 12:05'! additionsToViewerCategoryPenUse "Answer viewer additions for the 'pen use' category" ^#( #'pen use' ( (slot penColor 'the color of ink used by the pen' Color readWrite Player getPenColor Player setPenColor:) (slot penSize 'the width of the pen' Number readWrite Player getPenSize Player setPenSize:) (slot penDown 'whether the pen is currently down' Boolean readWrite Player getPenDown Player setPenDown:) (slot trailStyle 'determines whether lines, arrows, arrowheads, or dots are used when I put down a pen trail' TrailStyle readWrite Player getTrailStyle Player setTrailStyle:) (slot dotSize 'diameter of dot to use when trailStyle is dots' Number readWrite Player getDotSize Player setDotSize:) (command clearOwnersPenTrails 'clear all pen trails in my containing playfield') ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 2/19/2003 18:04'! additionsToViewerCategoryScripting "Answer viewer additions for the 'scripting' category" ^#( scripting ( (command startScript: 'start the given script ticking' ScriptName) (command pauseScript: 'make the given script be "paused"' ScriptName) (command stopScript: 'make the given script be "normal"' ScriptName) (command startAll: 'start the given script ticking in the object and all of its siblings.' ScriptName) (command pauseAll: 'make the given script be "paused" in the object and all of its siblings' ScriptName) (command stopAll: 'make the given script be "normal" in the object and all of its siblings' ScriptName) (command doScript: 'run the given script once, on the next tick' ScriptName) (command tellSelfAndAllSiblings: 'run the given script in the object and in all of its siblings' ScriptName) (command tellAllSiblings: 'send a message to all siblings' ScriptName)))! ! !Morph class methodsFor: 'scripting' stamp: 'RAA 5/18/2001 12:48'! additionsToViewerCategoryScripts "note: if you change the thing below you also need to change #tileScriptCommands." ^#( scripts ( (command emptyScript 'an empty script') ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'nk 10/14/2004 10:59'! additionsToViewerCategoryTests "Answer viewer additions for the 'tests' category." "Note: Because of intractable performance problems in continuously evaluating isOverColor in a Viewer, the isOverColor entry is not given a readout" ^#( #tests ( (slot isOverColor 'whether any part of the object is over the given color' Boolean readOnly Player seesColor: unused unused) (slot isUnderMouse 'whether the object is under the current mouse position' Boolean readOnly Player getIsUnderMouse unused unused) (slot colorSees 'whether the given color sees the given color' Boolean readOnly Player color:sees: unused unused) (slot overlaps 'whether I overlap a given object' Boolean readOnly Player overlaps: unused unused) (slot overlapsAny 'whether I overlap a given object or one of its siblings or similar objects' Boolean readOnly Player overlapsAny: unused unused) (slot touchesA 'whether I overlap any Sketch that is showing the same picture as a particular prototype.' Boolean readOnly Player touchesA: unused unused) (slot obtrudes 'whether the object sticks out over its container''s edge' Boolean readOnly Player getObtrudes unused unused) ) ) ! ! !Morph class methodsFor: 'scripting' stamp: 'bf 9/11/2004 17:18'! hasAdditionsToViewerCategories ^ self class selectors anySatisfy: [:each | each == #additionsToViewerCategories or: [(each beginsWith: 'additionsToViewerCategory') and: [(each at: 26 ifAbsent: []) ~= $:]]]! ! !Morph class methodsFor: 'scripting' stamp: 'yo 3/15/2005 14:10'! helpContributions "Answer a list of pairs of the form (<symbol> <help message> ) to contribute to the system help dictionary" "NB: Many of the items here are not needed any more since they're specified as part of command definitions now. Someone needs to take the time to go through the list and remove items no longer needed. But who's got that kind of time?" ^ #( (acceptScript:for: 'submit the contents of the given script editor as the code defining the given selector') (actorState 'return the ActorState object for the receiver, creating it if necessary') (addInstanceVariable 'start the interaction for adding a new variable to the object') (addPlayerMenuItemsTo:hand: 'add player-specific menu items to the given menu, on behalf of the given hand. At present, these are only commands relating to the turtle') (addYesNoToHand 'Press here to tear off a TEST/YES/NO unit which you can drop into your script') (allScriptEditors 'answer a list off the extant ScriptEditors for the receiver') (amount 'The amount of displacement') (angle 'The angular displacement') (anonymousScriptEditorFor: 'answer a new ScriptEditor object to serve as the place for scripting an anonymous (unnamed, unsaved) script for the receiver') (append: 'add an object to this container') (prepend: 'add an object to this container') (assignDecrGetter:setter:amt: 'evaluate the decrement variant of assignment') (assignGetter:setter:amt: 'evaluate the vanilla variant of assignment') (assignIncrGetter:setter:amt: 'evalute the increment version of assignment') (assignMultGetter:setter:amt: 'evaluate the multiplicative version of assignment') (assureEventHandlerRepresentsStatus 'make certain that the event handler associated with my current costume is set up to conform to my current script-status') (assureExternalName 'If I do not currently have an external name assigned, get one now') (assureUniClass 'make certain that I am a member a uniclass (i.e. a unique subclass); if I am not, create one now and become me into an instance of it') (availableCostumeNames 'answer a list of strings representing the names of all costumes currently available for me') (availableCostumesForArrows 'answer a list of actual, instantiated costumes for me, which can be cycled through as the user hits a next-costume or previous-costume button in a viewer') (beep: 'make the specified sound') (borderColor 'The color of the object''s border') (borderWidth 'The width of the object''s border') (bottom 'My bottom edge, measured downward from the top edge of the world') (bounce: 'If object strayed beyond the boundaries of its container, make it reflect back into it, making the specified noise while doing so.') (bounce 'If object strayed beyond the boundaries of its container, make it reflect back into it') (chooseTrigger 'When this script should run. "normal" means "only when called"') (clearTurtleTrails 'Clear all the pen trails in the interior.') (clearOwnersPenTrails 'Clear all the pen trails in my container.') (color 'The object''s interior color') (colorSees 'Whether a given color in the object is over another given color') (colorUnder 'The color under the center of the object') (copy 'Return a new object that is very much like this one') (cursor 'The index of the chosen element') (deleteCard 'Delete the current card.') (dismiss 'Click here to dismiss me') (doMenuItem: 'Do a menu item, the same way as if it were chosen manually') (doScript: 'Perform the given script once, on the next tick.') (elementNumber 'My element number as seen by my owner') (fire 'Run any and all button-firing scripts of this object') (firstPage 'Go to first page of book') (followPath 'Retrace the path the object has memorized, if any.') (forward: 'Moves the object forward in the direction it is heading') (goto: 'Go to the specfied book page') (goToNextCardInStack 'Go to the next card') (goToPreviousCardInStack 'Go to the previous card.') (goToRightOf: 'Align the object just to the right of any specified object.') (heading 'Which direction the object is facing. 0 is straight up') (height 'The distance between the top and bottom edges of the object') (hide 'Make the object so that it does not display and cannot handle input') (initiatePainting 'Initiate painting of a new object in the standard playfield.') (initiatePaintingIn: 'Initiate painting of a new object in the given place.') (isOverColor 'Whether any part of this object is directly over the specified color') (isUnderMouse 'Whether any part of this object is beneath the current mouse-cursor position') (lastPage 'Go to the last page of the book.') (left 'My left edge, measured from the left edge of the World') (leftRight 'The horizontal displacement') (liftAllPens 'Lift the pens on all the objects in my interior.') (lowerAllPens 'Lower the pens on all the objects in my interior.') (mouseX 'The x coordinate of the mouse pointer') (mouseY 'The y coordinate of the mouse pointer') (moveToward: 'Move in the direction of another object.') (insertCard 'Create a new card.') (nextPage 'Go to next page.') (numberAtCursor 'The number held by the object at the chosen element') (objectNameInHalo 'Object''s name -- To change: click here, edit, hit ENTER') (obtrudes 'Whether any part of the object sticks out beyond its container''s borders') (offerScriptorMenu 'The Scriptee. Press here to get a menu') (pauseScript: 'Make a running script become paused.') (penDown 'Whether the object''s pen is down (true) or up (false)') (penColor 'The color of the object''s pen') (penSize 'The size of the object''s pen') (clearPenTrails 'Clear all pen trails in the current playfield') (playerSeeingColorPhrase 'The player who "sees" a given color') (previousPage 'Go to previous page') (show 'If object was hidden, make it show itself again.') (startScript: 'Make a script start running.') (stopScript: 'Make a script stop running.') (top 'My top edge, measured downward from the top edge of the world') (right 'My right edge, measured from the left edge of the world') (roundUpStrays 'Bring all out-of-container subparts back into view.') (scaleFactor 'The amount by which the object is scaled') (stopScript: 'make the specified script stop running') (tellAllSiblings: 'send a message to all of my sibling instances') (try 'Run this command once.') (tryMe 'Click here to run this script once; hold button down to run repeatedly') (turn: 'Change the heading of the object by the specified amount') (unhideHiddenObjects 'Unhide all hidden objects.') (upDown 'The vertical displacement') (userScript 'This is a script defined by you.') (userSlot 'This is a variable defined by you. Click here to change its type') (valueAtCursor 'The chosen element') (wearCostumeOf: 'Wear the same kind of costume as the other object') (width 'The distance between the left and right edges of the object') (wrap 'If object has strayed beond the boundaries of its container, make it reappear from the opposite edge.') (x 'The x coordinate, measured from the left of the container') (y 'The y-coordinate, measured upward from the bottom of the container') ) ! ! !Morph class methodsFor: 'scripting' stamp: 'sw 9/17/2002 10:00'! vectorAdditions "Answer slot/command definitions for the vector experiment" ^ # ( (slot x 'The x coordinate' Number readWrite Player getX Player setX:) (slot y 'The y coordinate' Number readWrite Player getY Player setY:) (slot heading 'Which direction the object is facing. 0 is straight up' Number readWrite Player getHeading Player setHeading:) (slot distance 'The length of the vector connecting the origin to the object''s position' Number readWrite Player getDistance Player setDistance:) (slot theta 'The angle between the positive x-axis and the vector connecting the origin to the object''s position' Number readWrite Player getTheta Player setTheta: ) (slot headingTheta 'The angle that my heading vector makes with the positive x-axis' Number readWrite Player getHeadingTheta Player setHeadingTheta:) (command + 'Adds two players together, treating each as a vector from the origin.' Player) (command - 'Subtracts one player from another, treating each as a vector from the origin.' Player) (command * 'Multiply a player by a Number, treating the Player as a vector from the origin.' Number) (command / 'Divide a player by a Number, treating the Player as a vector from the origin.' Number) (command incr: 'Each Player is a vector from the origin. Increase one by the amount of the other.' Player) (command decr: 'Each Player is a vector from the origin. Decrease one by the amount of the other.' Player) (command multBy: 'A Player is a vector from the origin. Multiply its length by the factor.' Number) (command dividedBy: 'A Player is a vector from the origin. Divide its length by the factor.' Number) )! ! !Morph class methodsFor: 'arrow head size'! defaultArrowheadSize ^ 5 @ 4! ! !Morph class methodsFor: 'arrow head size'! obtainArrowheadFor: aPrompt defaultValue: defaultPoint "Allow the user to supply a point to serve as an arrowhead size. Answer nil if we fail to get a good point" | result | result := FillInTheBlank request: aPrompt initialAnswer: defaultPoint asString. result isEmptyOrNil ifTrue: [^ nil]. ^ [(Point readFrom: (ReadStream on: result))] on: Error do: [:ex | nil].! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 10/11/2003 18:06'! additionToViewerCategorySelectors "Answer the list of my selectors matching additionsToViewerCategory*" ^self class organization allMethodSelectors select: [ :ea | (ea beginsWith: 'additionsToViewerCategory') and: [ (ea at: 26 ifAbsent: []) ~= $: ]]! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 10/11/2003 18:17'! additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories. This version factors each category definition into a separate method. Subclasses that have additions can either: - override this method, or - (preferably) define one or more additionToViewerCategory* methods. The advantage of the latter technique is that class extensions may be added by external packages without having to re-define additionsToViewerCategories. " ^#()! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/29/2004 16:35'! additionsToViewerCategory: aCategoryName "Answer a list of viewer specs for items to be added to the given category on behalf of the receiver. Each class in a morph's superclass chain is given the opportunity to add more things" aCategoryName == #vector ifTrue: [^ self vectorAdditions]. ^self allAdditionsToViewerCategories at: aCategoryName ifAbsent: [ #() ].! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 9/11/2004 16:56'! allAdditionsToViewerCategories "Answer a Dictionary of (<categoryName> <list of category specs>) that defines the phrases this kind of morph wishes to add to various Viewer categories. This version allows each category definition to be defined in one or more separate methods. Subclasses that have additions can either: - override #additionsToViewerCategories, or - (preferably) define one or more additionToViewerCategory* methods. The advantage of the latter technique is that class extensions may be added by external packages without having to re-define additionsToViewerCategories." " Morph allAdditionsToViewerCategories " | dict | dict := IdentityDictionary new. (self class includesSelector: #additionsToViewerCategories) ifTrue: [self additionsToViewerCategories do: [:group | group pairsDo: [:key :list | (dict at: key ifAbsentPut: [OrderedCollection new]) addAll: list]]]. self class selectors do: [:aSelector | ((aSelector beginsWith: 'additionsToViewerCategory') and: [(aSelector at: 26 ifAbsent: []) ~= $:]) ifTrue: [(self perform: aSelector) pairsDo: [:key :list | (dict at: key ifAbsentPut: [OrderedCollection new]) addAll: list]]]. ^ dict! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 10/11/2003 17:48'! noteCompilationOf: aSelector meta: isMeta "Any change to an additionsToViewer... method can invalidate existing etoy vocabularies. The #respondsTo: test is to allow loading the FlexibleVocabularies change set without having to worry about method ordering." (isMeta and: [(aSelector beginsWith: 'additionsToViewer') and: [self respondsTo: #hasAdditionsToViewerCategories]]) ifTrue: [Vocabulary changeMadeToViewerAdditions]. super noteCompilationOf: aSelector meta: isMeta! ! !Morph class methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 10/8/2004 16:21'! unfilteredCategoriesForViewer "Answer a list of symbols representing the categories to offer in the viewer for one of my instances, in order of: - masterOrderingOfCategorySymbols first - others last in order by translated wording" " Morph unfilteredCategoriesForViewer " | aClass additions masterOrder | aClass _ self. additions _ OrderedCollection new. [aClass == Morph superclass ] whileFalse: [ additions addAll: (aClass allAdditionsToViewerCategories keys asSortedCollection: [ :a :b | a translated < b translated ]). aClass _ aClass superclass ]. masterOrder := EToyVocabulary masterOrderingOfCategorySymbols. ^(masterOrder intersection: additions), (additions difference: masterOrder).! ! !Morph class methodsFor: '*customevents-user events' stamp: 'nk 11/1/2004 10:14'! additionsToViewerCategoryUserEvents "Answer viewer additions relating to user-defined events for the 'scripting' category" ^(Preferences allowEtoyUserCustomEvents) ifTrue: [ #(scripting ( (command triggerCustomEvent: 'trigger a user-defined (global) event' CustomEvents) (slot triggeringObject 'the object that is triggering an event, either user-defined or pre-defined' Player readOnly Player getTriggeringObject unused unused) )) ] ifFalse: [ #(scripting ( (slot triggeringObject 'the object that is triggering an event, either user-defined or pre-defined' Player readOnly Player getTriggeringObject unused unused))) ] ! ! !Morph class methodsFor: '*connectors-scripting' stamp: 'nk 9/10/2004 11:34'! additionsToViewerCategoryConnection "Answer viewer additions for the 'connection' category" "Vocabulary initialize" ^{ #'connections to me'. #( (command tellAllPredecessors: 'Send a message to all graph predecessors' ScriptName) (command tellAllSuccessors: 'Send a message to all graph predecessors' ScriptName) (command tellAllIncomingConnections: 'Send a message to all the connectors whose destination end is connected to me' ScriptName) (command tellAllOutgoingConnections: 'Send a message to all the connectors whose source end is connected to me' ScriptName) (slot incomingConnectionCount 'The number of connectors whose destination end is connected to me' Number readOnly Player getIncomingConnectionCount unused unused) (slot outgoingConnectionCount 'The number of connectors whose source end is connected to me' Number readOnly Player getOutgoingConnectionCount unused unused) ) } ! ! !Morph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:20'! allSketchMorphClasses "Morph allSketchMorphClasses" ^ Array streamContents: [:s | self withAllSubclassesDo: [:cls | cls isSketchMorphClass ifTrue: [s nextPut: cls ]]] ! ! !Morph class methodsFor: 'testing' stamp: 'yo 3/17/2005 09:07'! allSketchMorphForms "Answer a Set of forms of SketchMorph (sub) instances, except those used as button images, ones being edited, and those with 0 extent." | reasonableForms form | reasonableForms := Set new. Morph allSketchMorphClasses do: [:cls | cls allInstances do: [:m | (m owner isKindOf: SketchEditorMorph orOf: IconicButton) ifFalse: [form _ m form. ((form width > 0) and: [form height > 0]) ifTrue: [reasonableForms add: form]]]]. ^ reasonableForms! ! !Morph class methodsFor: 'testing' stamp: 'nk 6/12/2004 09:17'! isSketchMorphClass ^false! ! !MorphExample methodsFor: 'initialization' stamp: 'dgd 2/21/2003 19:59'! initialize "initialize the state of the receiver" super initialize. phase _ 1. self extent: 200 @ 200. ball _ EllipseMorph new extent: 30 @ 30. self addMorph: ((star _ StarMorph new extent: 150 @ 150) center: self center)! ! !MorphExample methodsFor: 'stepping and presenter' stamp: 'kfr 10/26/2003 18:33'! step phase _ phase\\8 + 1. phase = 1 ifTrue: [^ ball delete]. phase < 4 ifTrue:[^self]. phase = 4 ifTrue: [self addMorph: ball]. ball align: ball center with: (star vertices at: (phase-3*2)).! ! !MorphExample commentStamp: 'kfr 10/26/2003 18:38' prior: 0! This is a example of how to use a morph. It consists of only two methods, initialize and step. DoIt: MorphExample new openInWorld. ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:56'! actorState "answer the redeiver's actorState" ^ actorState ! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53'! actorState: anActorState "change the receiver's actorState" actorState _ anActorState! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! balloonTextSelector: aSymbol "change the receiver's balloonTextSelector" balloonTextSelector _ aSymbol! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! eventHandler "answer the receiver's eventHandler" ^ eventHandler ! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:57'! externalName: aString "change the receiver's externalName" externalName _ aString! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:37'! isPartsDonor "answer whether the receiver is PartsDonor" ^ isPartsDonor! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:40'! isPartsDonor: aBoolean "change the receiver's isPartDonor property" isPartsDonor _ aBoolean! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'! locked "answer whether the receiver is Locked" ^ locked! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'! locked: aBoolean "change the receiver's locked property" locked _ aBoolean! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:42'! player "answer the receiver's player" ^ player! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:53'! player: anObject "change the receiver's player" player _ anObject ! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'! sticky: aBoolean "change the receiver's sticky property" sticky _ aBoolean! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41'! visible "answer whether the receiver is visible" ^ visible! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'! layoutFrame: aLayoutFrame aLayoutFrame isNil ifTrue: [self removeProperty: #layoutFrame] ifFalse: [self setProperty: #layoutFrame toValue: aLayoutFrame]! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'! layoutPolicy: aLayoutPolicy aLayoutPolicy isNil ifTrue: [self removeProperty: #layoutPolicy] ifFalse: [self setProperty: #layoutPolicy toValue: aLayoutPolicy]! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'dgd 2/22/2003 13:32'! layoutProperties: newProperties "Return the current layout properties associated with the receiver" newProperties isNil ifTrue: [self removeProperty: #layoutProperties] ifFalse: [self setProperty: #layoutProperties toValue: newProperties]! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:05'! assureOtherProperties "creates an otherProperties for the receiver if needed" self hasOtherProperties ifFalse: [self initializeOtherProperties]. ^ self otherProperties! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:03'! hasOtherProperties "answer whether the receiver has otherProperties" ^ self otherProperties notNil! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:15'! hasProperty: aSymbol "Answer whether the receiver has the property named aSymbol" | property | self hasOtherProperties ifFalse: [^ false]. property _ self otherProperties at: aSymbol ifAbsent: []. property isNil ifTrue: [^ false]. property == false ifTrue: [^ false]. ^ true! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:12'! initializeOtherProperties "private - initializes the receiver's otherProperties" self privateOtherProperties: IdentityDictionary new! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:04'! otherProperties "answer the receiver's otherProperties" ^ otherProperties! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:20'! privateOtherProperties: anIndentityDictionary "private - change the receiver's otherProperties" otherProperties _ anIndentityDictionary ! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:12'! removeOtherProperties "Remove the 'other' properties" self privateOtherProperties: nil! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:17'! removeProperty: aSymbol "removes the property named aSymbol if it exists" self hasOtherProperties ifFalse: [^ self]. self otherProperties removeKey: aSymbol ifAbsent: []. self otherProperties isEmpty ifTrue: [self removeOtherProperties]! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:49'! setProperty: aSymbol toValue: abObject "change the receiver's property named aSymbol to anObject" self assureOtherProperties at: aSymbol put: abObject! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/22/2003 13:32'! sortedPropertyNames "answer the receiver's property names in a sorted way" | props | props := WriteStream on: (Array new: 10). locked == true ifTrue: [props nextPut: #locked]. visible == false ifTrue: [props nextPut: #visible]. sticky == true ifTrue: [props nextPut: #sticky]. balloonText isNil ifFalse: [props nextPut: #balloonText]. balloonTextSelector isNil ifFalse: [props nextPut: #balloonTextSelector]. externalName isNil ifFalse: [props nextPut: #externalName]. isPartsDonor == true ifTrue: [props nextPut: #isPartsDonor]. actorState isNil ifFalse: [props nextPut: #actorState]. player isNil ifFalse: [props nextPut: #player]. eventHandler isNil ifFalse: [props nextPut: #eventHandler]. self hasOtherProperties ifTrue: [self otherProperties associationsDo: [:a | props nextPut: a key]]. ^props contents sort: [:s1 :s2 | s1 <= s2]! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:00'! valueOfProperty: aSymbol "answer the value of the receiver's property named aSymbol" ^ self valueOfProperty: aSymbol ifAbsent: []! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:09'! valueOfProperty: aSymbol ifAbsent: aBlock "if the receiver possesses a property of the given name, answer its value. If not then evaluate aBlock and answer the result of this block evaluation" self hasOtherProperties ifFalse: [^ aBlock value]. ^ self otherProperties at: aSymbol ifAbsent: [^ aBlock value]! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'dgd 2/16/2003 21:28'! valueOfProperty: aSymbol ifAbsentPut: aBlock "If the receiver possesses a property of the given name, answer its value. If not, then create a property of the given name, give it the value obtained by evaluating aBlock, then answer that value" ^self assureOtherProperties at: aSymbol ifAbsentPut: aBlock! ! !MorphExtension methodsFor: 'copying' stamp: 'dgd 2/22/2003 13:32'! updateReferencesUsing: aDictionary "Update intra-morph references within a composite morph that has been copied. For example, if a button refers to morph X in the orginal composite then the copy of that button in the new composite should refer to the copy of X in new composite, not the original X. This default implementation updates the contents of any morph-bearing slot." | old | eventHandler isNil ifFalse: [self eventHandler: self eventHandler copy. 1 to: self eventHandler class instSize do: [:i | old := eventHandler instVarAt: i. old isMorph ifTrue: [eventHandler instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]]. self hasOtherProperties ifTrue: ["" self otherProperties associationsDo: [:assn | assn value: (aDictionary at: assn value ifAbsent: [assn value])]]! ! !MorphExtension methodsFor: 'object fileIn' stamp: 'dgd 2/16/2003 21:06'! convertProperty: aSymbol toValue: anObject "These special cases move old properties into named fields of the extension" aSymbol == #locked ifTrue: [^ locked _ anObject]. aSymbol == #visible ifTrue: [^ visible _ anObject]. aSymbol == #sticky ifTrue: [^ sticky _ anObject]. aSymbol == #balloonText ifTrue: [^ balloonText _ anObject]. aSymbol == #balloonTextSelector ifTrue: [^ balloonTextSelector _ anObject]. aSymbol == #actorState ifTrue: [^ actorState _ anObject]. aSymbol == #player ifTrue: [^ player _ anObject]. aSymbol == #name ifTrue: [^ externalName _ anObject]. "*renamed*" aSymbol == #partsDonor ifTrue: [^ isPartsDonor _ anObject]. "*renamed*" self assureOtherProperties at: aSymbol put: anObject! ! !MorphExtension methodsFor: 'other' stamp: 'dgd 2/16/2003 21:09'! inspectElement "Create and schedule an Inspector on the otherProperties and the named properties." | key obj | key _ (SelectionMenu selections: self sortedPropertyNames) startUpWithCaption: 'Inspect which property?'. key ifNil: [^ self]. obj _ self otherProperties at: key ifAbsent: ['nOT a vALuE']. obj = 'nOT a vALuE' ifTrue: [(self perform: key) inspect "named properties"] ifFalse: [obj inspect]! ! !MorphExtension methodsFor: 'other' stamp: 'dgd 2/16/2003 21:14'! isDefault "Return true if the receiver is a default and can be omitted" locked == true ifTrue: [^ false]. visible == false ifTrue: [^ false]. sticky == true ifTrue: [^ false]. balloonText isNil ifFalse: [^ false]. balloonTextSelector isNil ifFalse: [^ false]. externalName isNil ifFalse: [^ false]. isPartsDonor == true ifTrue: [^ false]. actorState isNil ifFalse: [^ false]. player isNil ifFalse: [^ false]. eventHandler isNil ifFalse: [^ false]. self hasOtherProperties ifTrue: [self otherProperties isEmpty ifFalse: [^ false]]. ^ true! ! !MorphExtension methodsFor: 'printing' stamp: 'nk 7/20/2003 11:00'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." super printOn: aStream. aStream nextPutAll: ' ' , self identityHashPrintString. locked == true ifTrue: [aStream nextPutAll: ' [locked] ']. visible == false ifTrue: [aStream nextPutAll: '[not visible] ']. sticky == true ifTrue: [aStream nextPutAll: ' [sticky] ']. balloonText ifNotNil: [aStream nextPutAll: ' [balloonText] ']. balloonTextSelector ifNotNil: [aStream nextPutAll: ' [balloonTextSelector: ' , balloonTextSelector printString , '] ']. externalName ifNotNil: [aStream nextPutAll: ' [externalName = ' , externalName , ' ] ']. isPartsDonor == true ifTrue: [aStream nextPutAll: ' [isPartsDonor] ']. player ifNotNil: [aStream nextPutAll: ' [player = ' , player printString , '] ']. eventHandler ifNotNil: [aStream nextPutAll: ' [eventHandler = ' , eventHandler printString , '] ']. (self hasOtherProperties not or: [ self otherProperties isEmpty ]) ifTrue: [^ self]. aStream nextPutAll: ' [other: '. self otherProperties keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')']. aStream nextPut: $]! ! !MorphExtension methodsFor: '*connectors-copying' stamp: 'nk 5/1/2004 17:20'! copyWeakly "list of names of properties whose values should be weak-copied when veryDeepCopying a morph. See DeepCopier." ^ #(formerOwner newPermanentPlayer logger graphModel gestureDictionaryOrName) "add yours to this list" "formerOwner should really be nil at the time of the copy, but this will work just fine."! ! !MorphExtension methodsFor: '*connectors-copying' stamp: 'nk 5/1/2004 17:23'! propertyNamesNotCopied "list of names of properties whose values should be deleted when veryDeepCopying a morph. See DeepCopier." ^ #(connectedConstraints connectionHighlights highlightedTargets) "add yours to this list" ! ! !MorphExtension methodsFor: '*connectors-copying' stamp: 'nk 5/1/2004 17:39'! veryDeepFixupWith: deepCopier "If target and arguments fields were weakly copied, fix them here. If they were in the tree being copied, fix them up, otherwise point to the originals!!!!" super veryDeepFixupWith: deepCopier. otherProperties ifNil: [ ^self ]. "Properties whose values are only copied weakly replace those values if they were copied via another path" self copyWeakly do: [ :propertyName | otherProperties at: propertyName ifPresent: [ :property | otherProperties at: propertyName put: (deepCopier references at: property ifAbsent: [ property ])]]. ! ! !MorphExtension methodsFor: '*connectors-copying' stamp: 'nk 5/1/2004 17:45'! veryDeepInner: deepCopier "Copy all of my instance variables. Some otherProperties need to be not copied at all, but shared. Their names are given by copyWeakly. Some otherProperties should not be copied or shared. Their names are given by propertyNamesNotCopied. This is special code for the dictionary. See DeepCopier, and veryDeepFixupWith:." | namesOfWeaklyCopiedProperties weaklyCopiedValues | super veryDeepInner: deepCopier. locked _ locked veryDeepCopyWith: deepCopier. visible _ visible veryDeepCopyWith: deepCopier. sticky _ sticky veryDeepCopyWith: deepCopier. balloonText _ balloonText veryDeepCopyWith: deepCopier. balloonTextSelector _ balloonTextSelector veryDeepCopyWith: deepCopier. externalName _ externalName veryDeepCopyWith: deepCopier. isPartsDonor _ isPartsDonor veryDeepCopyWith: deepCopier. actorState _ actorState veryDeepCopyWith: deepCopier. player _ player veryDeepCopyWith: deepCopier. "Do copy the player of this morph" eventHandler _ eventHandler veryDeepCopyWith: deepCopier. "has its own restrictions" otherProperties ifNil: [ ^self ]. otherProperties := otherProperties copy. self propertyNamesNotCopied do: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. namesOfWeaklyCopiedProperties _ self copyWeakly. weaklyCopiedValues _ namesOfWeaklyCopiedProperties collect: [ :propName | otherProperties removeKey: propName ifAbsent: [] ]. "Now copy all the others." otherProperties := otherProperties veryDeepCopyWith: deepCopier. "And replace the weak ones." namesOfWeaklyCopiedProperties with: weaklyCopiedValues do: [ :name :value | value ifNotNil: [ otherProperties at: name put: value ]]. ! ! !MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'! getWorld ^ world ifNil: [world := Project newMorphic world]! ! !MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'! setUp morph := Morph new! ! !MorphTest methodsFor: 'initialize-release' stamp: 'tak 1/21/2005 11:12'! tearDown morph delete. world ifNotNil: [Project deletingProject: world project]! ! !MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/4/2003 00:11'! testIntoWorldCollapseOutOfWorld | m1 m2 collapsed | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). "add them to basic morph" morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). "open the guy" morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). "collapse it" collapsed := CollapsedMorph new beReplacementFor: morph. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). "expand it" collapsed collapseOrExpand. self assert: (m1 intoWorldCount = 2). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 2). self assert: (m2 outOfWorldCount = 1). "delete it" morph delete. self assert: (m1 intoWorldCount = 2). self assert: (m1 outOfWorldCount = 2). self assert: (m2 intoWorldCount = 2). self assert: (m2 outOfWorldCount = 2). ! ! !MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/4/2003 00:12'! testIntoWorldDeleteOutOfWorld | m1 m2 | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph delete. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). ! ! !MorphTest methodsFor: 'testing - into/outOf World' stamp: 'ar 8/10/2003 18:30'! testIntoWorldTransferToNewGuy | m1 m2 | "Create the guys" m1 := TestInWorldMorph new. m2 := TestInWorldMorph new. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. m1 addMorphFront: m2. self assert: (m1 intoWorldCount = 0). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 0). self assert: (m2 outOfWorldCount = 0). morph openInWorld. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m2. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph addMorphFront: m1. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). m2 addMorphFront: m1. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 0). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 0). morph delete. self assert: (m1 intoWorldCount = 1). self assert: (m1 outOfWorldCount = 1). self assert: (m2 intoWorldCount = 1). self assert: (m2 outOfWorldCount = 1). ! ! !MorphTest methodsFor: 'testing - classification' stamp: 'md 4/16/2003 17:11'! testIsMorph self assert: (morph isMorph).! ! !MorphTest methodsFor: 'testing - initialization' stamp: 'md 4/16/2003 17:10'! testOpenInWorld self shouldnt: [morph openInWorld] raise: Error.! ! !MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:31'! testOverlapAny "self debug: #testOverlapAny" | p1 p2 | p1 _ Morph new assuredPlayer. p2 _ EllipseMorph new assuredPlayer. "Same position" p1 costume position: 0@0. p2 costume position: 0@0. self assert: (p1 overlapsAny: p2). "Different position" p1 costume position: 0@0. p2 costume position: 500@0. self assert: (p1 overlapsAny: p2) not.! ! !MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:56'! testOverlapAnyDeletedPlayer "self debug: #testOverlapAnyDeletedPlayer" | me friend sibling | me := Morph new assuredPlayer assureUniClass; yourself. friend := EllipseMorph new assuredPlayer assureUniClass; yourself. sibling := friend getNewClone. sibling costume delete. self getWorld addMorph: me costume. "Same position but deleted" me costume position: 0 @ 0. friend costume position: 0 @ 0. sibling costume position: 0 @ 0. self assert: (me overlapsAny: friend) not. self assert: (me overlapsAny: sibling) not! ! !MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:40'! testOverlapAnyScriptedPlayer "self debug: #testOverlapAnyScriptedPlayer" | me friend other sibling | me := Morph new assuredPlayer assureUniClass; yourself. friend := EllipseMorph new assuredPlayer assureUniClass; yourself. sibling := friend getNewClone. other := EllipseMorph new assuredPlayer assureUniClass; yourself. self getWorld addMorph: me costume; addMorph: friend costume; addMorph: other costume; addMorph: sibling costume. "myself" self assert: (me overlapsAny: me) not. "Same position with sibling" me costume position: 0 @ 0. friend costume position: 500 @ 0. other costume position: 500 @ 0. sibling costume position: 0@0. self assert: (me overlapsAny: friend). "Different position with sibling but same class" me costume position: 0 @ 0. friend costume position: 500 @ 0. sibling costume position: 500@ 0. other costume position: 0 @ 0. self assert: (me overlapsAny: friend) not! ! !MorphTest methodsFor: 'testing - etoys' stamp: 'tak 1/21/2005 11:32'! testOverlapAnyUnscriptedPlayer "self debug: #testOverlapAnyUnscriptedPlayer" | p1 p2 p3 | p1 := Morph new assuredPlayer. p2 := EllipseMorph new assuredPlayer. p3 := EllipseMorph new assuredPlayer. self getWorld addMorph: p1 costume; addMorph: p2 costume; addMorph: p3 costume. "Same class, same position" p1 costume position: 0 @ 0. p2 costume position: 500 @ 0. p3 costume position: 0 @ 0. self assert: (p1 overlapsAny: p2). "Same class, different position" p1 costume position: 0 @ 0. p2 costume position: 1000 @ 0. p3 costume position: 500 @ 0. self assert: (p1 overlapsAny: p2) not. ! ! !MorphTest commentStamp: '<historical>' prior: 0! This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'md 10/22/2003 15:24'! revealOriginal ((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) ifTrue: [^Beeper beep]. morphRepresented owner isNil ifTrue: [^owner replaceSubmorph: self by: morphRepresented]. Beeper beep! ! !MorphThumbnail methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !MorphThumbnail methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:51'! initialize "initialize the state of the receiver" | f | super initialize. "" f _ Form extent: 60 @ 80 depth: Display depth. f fill: f boundingBox fillColor: color. self form: f! ! !MorphThumbnail methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:53'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'reveal original morph' translated action: #revealOriginal. aCustomMenu add: 'grab original morph' translated action: #grabOriginal. ! ! !MorphThumbnail methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:37'! isPartsDonor "answer whether the receiver is PartsDonor" ^ self partRepresented isPartsDonor! ! !MorphThumbnail methodsFor: 'parts bin' stamp: 'dgd 2/16/2003 21:40'! isPartsDonor: aBoolean "change the receiver's isPartDonor property" self partRepresented isPartsDonor: aBoolean! ! !MorphWithSubmorphsWrapper methodsFor: 'hierarchy' stamp: 'ls 3/1/2004 17:34'! contents ^item submorphs collect: [ :m | self class with: m ]! ! !MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32' prior: 0! Display a morph in a SimpleHierarchicalListMorph, and arrange to recursively display the morph's submorphs. The "item" that is wrapped is the morph to display.! !MorphWorldController methodsFor: 'basic control sequence' stamp: 'di 11/16/2001 22:43'! controlLoop "Overridden to keep control active when the hand goes out of the view" | db | [self viewHasCursor "working in the window" or: [Sensor noButtonPressed "wandering with no button pressed" or: [model primaryHand submorphs size > 0 "dragging something outside"]]] whileTrue: "... in other words anything but clicking outside" [self controlActivity. "Check for reframing since we hold control here" db _ view superView displayBox. view superView controller checkForReframe. db = view superView displayBox ifFalse: [self controlInitialize "reframe world if bounds changed"]]. ! ! !MorphWorldController methodsFor: 'basic control sequence' stamp: 'di 11/16/2001 13:58'! controlTerminate "This window is becoming inactive; restore the normal cursor." Cursor normal show. ActiveWorld _ ActiveHand _ ActiveEvent _ nil! ! !MorphWorldView methodsFor: 'as yet unclassified' stamp: 'aoy 2/17/2003 01:26'! updateSubWindowExtent "If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView." | numMorphs subWindow scrollBarWidth | numMorphs := model submorphs size. "(Allow for the existence of an extra NewHandleMorph (for resizing).)" (numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^self]. subWindow := model submorphs detect: [:ea | ea respondsTo: #label] ifNone: [^self]. superView label = subWindow label ifFalse: [^self]. scrollBarWidth := (Preferences valueOfFlag: #inboardScrollbars) ifTrue: [0] ifFalse: [14]. subWindow position: model position + (scrollBarWidth @ -16). "adjust for WiW changes" subWindow extent: model extent - (scrollBarWidth @ -16). subWindow isActive ifFalse: [subWindow activate]! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:52'! convertToMVCWiWPasteUpMorph " MorphWorldView convertToMVCWiWPasteUpMorph " | current w newModel topView | Smalltalk isMorphic ifTrue: [^self inform: 'do this in MVC']. current := self allInstances select: [:each | each model class == PasteUpMorph]. current do: [:oldWorldView | w := MVCWiWPasteUpMorph newWorldForProject: nil. w color: oldWorldView model color; addAllMorphs: oldWorldView model submorphs. newModel := CautiousModel new initialExtent: 300 @ 300. topView := self fullColorWhenInactive ifTrue: [ColorSystemView new] ifFalse: [StandardSystemView new]. topView model: newModel; label: oldWorldView topView label; borderWidth: 1; addSubView: (self new model: w); backgroundColor: w color. topView controller openNoTerminate. topView reframeTo: (oldWorldView topView expandedFrame expandBy: (0 @ 0 extent: 0 @ topView labelHeight)). oldWorldView topView controller closeAndUnscheduleNoTerminate]. ScheduledControllers restore. Processor terminateActive! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 22:37'! openOn: aWorldMorph label: aString model: aModel "Open a view with the given label on the given WorldMorph." | topView | topView := self fullColorWhenInactive ifTrue: [topView := ColorSystemView new] ifFalse: [topView := StandardSystemView new]. topView model: aModel; label: aString; borderWidth: 1; addSubView: (self new model: aWorldMorph); backgroundColor: aWorldMorph color. "minimumSize: aWorldMorph extent + (2@2); " "add border width" topView controller open! ! !MorphicModel methodsFor: 'caching' stamp: 'sw 3/6/2001 11:22'! releaseCachedState "Release cached state of the receiver" (model ~~ self and: [model respondsTo: #releaseCachedState]) ifTrue: [model releaseCachedState]. super releaseCachedState! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color yellow! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:07'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 corner: 200 @ 100! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !MorphicModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:47'! initialize "initialize the state of the receiver" super initialize. "" open _ false! ! !MorphicModel methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:53'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. model ifNotNil: [model addModelMenuItemsTo: aCustomMenu forMorph: self hand: aHandMorph]. self isOpen ifTrue: [aCustomMenu add: 'close editing' translated action: #closeToEdits] ifFalse: [aCustomMenu add: 'open editing' translated action: #openToEdits]. ! ! !MorphicModel methodsFor: 'naming' stamp: 'dgd 2/21/2003 23:00'! choosePartName "When I am renamed, get a slot, make default methods, move any existing methods. ** Does not clean up old inst var name or methods** " | old | old := slotName. super choosePartName. slotName ifNil: [^self]. "user chose bad slot name" self model: self world model slotName: slotName. old isNil ifTrue: [self compilePropagationMethods] ifFalse: [self copySlotMethodsFrom: old] "old ones not erased!!"! ! !MorphicModel methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 18:51'! allKnownNames "Return a list of all known names based on the scope of the receiver. If the receiver is a member of a uniclass, incorporate the original 1997 logic that queries the known names of the values of all the instance variables." | superNames | superNames := super allKnownNames. "gather them from submorph tree" ^self belongsToUniClass ifTrue: [superNames , (self instanceVariableValues select: [:e | e notNil and: [e knownName notNil]] thenCollect: [:e | e knownName])] ifFalse: [superNames]! ! !MorphicModel methodsFor: 'submorphs-add/remove' stamp: 'gm 2/22/2003 12:51'! delete (model isMorphicModel) ifFalse: [^super delete]. slotName ifNotNil: [(PopUpMenu confirm: 'Shall I remove the slot ' , slotName , ' along with all associated methods?') ifTrue: [(model class selectors select: [:s | s beginsWith: slotName]) do: [:s | model class removeSelector: s]. (model class instVarNames includes: slotName) ifTrue: [model class removeInstVarName: slotName]] ifFalse: [(PopUpMenu confirm: '...but should I at least dismiss this morph? [choose no to leave everything unchanged]') ifFalse: [^self]]]. super delete! ! !MorphicModel class methodsFor: 'compilation' stamp: 'sw 5/23/2001 13:51'! chooseNewName "Choose a new name for the receiver, persisting until an acceptable name is provided or until the existing name is resubmitted" | oldName newName | oldName _ self name. [newName _ (FillInTheBlank request: 'Please give this Model a name' initialAnswer: oldName) asSymbol. newName = oldName ifTrue: [^ self]. Smalltalk includesKey: newName] whileTrue: [self inform: 'Sorry, that name is already in use.']. self rename: newName.! ! !MorphicModel class methodsFor: 'prototype access' stamp: 'gm 2/22/2003 19:13'! prototype: aMorph "Store a copy of the given morph as a prototype to be copied to make new instances." aMorph ifNil: [prototype _ nil. ^ self]. prototype _ aMorph veryDeepCopy. (prototype isMorphicModel) ifTrue: [prototype model: nil slotName: nil]. ! ! !MorphicModel class methodsFor: 'queries' stamp: 'sw 2/27/2002 14:58'! baseUniclass "Answer the uniclass that new instances should be instances of. This protocol is primarily intended for the Player lineage, but can get sent to a MorphicModel subclass when the project-loading mechanism is scrambling to fix up projects that have naming conflicts with the project being loaded." | curr | curr _ self. [curr theNonMetaClass superclass name endsWithDigit] whileTrue: [curr _ curr superclass]. ^ curr "PlayWithMe1 baseUniclass"! ! !MorphicTransform methodsFor: 'composing' stamp: 'nk 3/9/2001 13:55'! composedWithLocal: aTransform aTransform isIdentity ifTrue:[^self]. self isIdentity ifTrue:[^aTransform]. aTransform isMorphicTransform ifFalse:[^super composedWithLocal: aTransform]. self isPureTranslation ifTrue:[ ^aTransform withOffset: aTransform offset + self offset]. aTransform isPureTranslation ifTrue:[ ^self withOffset: (self localPointToGlobal: aTransform offset negated) negated]. ^super composedWithLocal: aTransform.! ! !MouseButtonEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:00'! decodeFromStringArray: array "decode the receiver from an array of strings" type := array first asSymbol. position := CanvasDecoder decodePoint: (array second). buttons := CanvasDecoder decodeInteger: (array third). whichButton := CanvasDecoder decodeInteger: (array fourth)! ! !MouseButtonEvent methodsFor: '*geniestubs-accessing' stamp: 'nk 3/11/2004 17:44'! whichButton ^whichButton! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:23'! click clickSelector ifNotNil: [clickClient perform: clickSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:24'! doubleClick dblClickSelector ifNotNil: [clickClient perform: dblClickSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 13:09'! doubleClickTimeout dblClickTimeoutSelector ifNotNil: [ clickClient perform: dblClickTimeoutSelector with: firstClickDown]! ! !MouseClickState methodsFor: 'event handling' stamp: 'jcg 9/21/2001 11:27'! drag: event dragSelector ifNotNil: [clickClient perform: dragSelector with: event]! ! !MouseClickState methodsFor: 'event handling' stamp: 'nk 7/26/2004 10:21'! handleEvent: evt from: aHand "Process the given mouse event to detect a click, double-click, or drag. Return true if the event should be processed by the sender, false if it shouldn't. NOTE: This method heavily relies on getting *all* mouse button events." | localEvt timedOut isDrag | timedOut _ (evt timeStamp - firstClickTime) > dblClickTime. localEvt _ evt transformedBy: (clickClient transformedFrom: aHand owner). isDrag _ (localEvt position - firstClickDown position) r > dragThreshold. clickState == #firstClickDown ifTrue: [ "Careful here - if we had a slow cycle we may have a timedOut mouseUp event" (timedOut and:[localEvt isMouseUp not]) ifTrue:[ "timeout before #mouseUp -> keep waiting for drag if requested" clickState _ #firstClickTimedOut. dragSelector ifNil:[ aHand resetClickState. self doubleClickTimeout; click "***"]. ^true]. localEvt isMouseUp ifTrue:[ (timedOut or:[dblClickSelector isNil]) ifTrue:[ self click. aHand resetClickState. ^true]. "Otherwise transfer to #firstClickUp" firstClickUp _ evt copy. clickState _ #firstClickUp. "If timedOut or the client's not interested in dbl clicks get outta here" self click. aHand handleEvent: firstClickUp. ^false]. isDrag ifTrue:["drag start" self doubleClickTimeout. "***" aHand resetClickState. dragSelector "If no drag selector send #click instead" ifNil: [self click] ifNotNil: [self drag: firstClickDown]. ^true]. ^false]. clickState == #firstClickTimedOut ifTrue:[ localEvt isMouseUp ifTrue:["neither drag nor double click" aHand resetClickState. self doubleClickTimeout; click. "***" ^true]. isDrag ifTrue:["drag start" aHand resetClickState. self doubleClickTimeout; drag: firstClickDown. "***" ^true]. ^false]. clickState = #firstClickUp ifTrue:[ (timedOut) ifTrue:[ "timed out after mouseUp - signal timeout and pass the event" aHand resetClickState. self doubleClickTimeout. "***" ^true]. localEvt isMouseDown ifTrue:["double click" clickState _ #secondClickDown. ^false]]. clickState == #secondClickDown ifTrue: [ timedOut ifTrue:[ "timed out after second mouseDown - pass event after signaling timeout" aHand resetClickState. self doubleClickTimeout. "***" ^true]. isDrag ifTrue: ["drag start" self doubleClickTimeout. "***" aHand resetClickState. dragSelector "If no drag selector send #click instead" ifNil: [self click] ifNotNil: [self drag: firstClickDown]. ^true]. localEvt isMouseUp ifTrue: ["double click" aHand resetClickState. self doubleClick. ^false] ]. ^true ! ! !MouseClickState methodsFor: 'initialize' stamp: 'jcg 9/21/2001 13:08'! client: aMorph click: aClickSelector dblClick: aDblClickSelector dblClickTime: timeOut dblClickTimeout: aDblClickTimeoutSelector drag: aDragSelector threshold: aNumber event: firstClickEvent clickClient _ aMorph. clickSelector _ aClickSelector. dblClickSelector _ aDblClickSelector. dblClickTime _ timeOut. dblClickTimeoutSelector _ aDblClickTimeoutSelector. dragSelector _ aDragSelector. dragThreshold _ aNumber. firstClickDown _ firstClickEvent. firstClickTime _ firstClickEvent timeStamp. clickState _ #firstClickDown.! ! !MouseClickState methodsFor: 'as yet unclassified' stamp: 'nk 7/26/2004 09:13'! printOn: aStream super printOn: aStream. aStream nextPut: $[; print: clickState; nextPut: $] ! ! !MouseDownMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:45'! handlesMouseDown: evt ^model notNil! ! !MouseDownMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:54'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. "template..." aCustomMenu addLine. aCustomMenu add: 'set variable name...' translated action: #renameMe. aCustomMenu addLine. aCustomMenu add: 'plug mouseDown to model slot' translated action: #plugMouseDownToSlot. aCustomMenu add: 'plug mouseMove to model slot' translated action: #plugMouseMoveToSlot. aCustomMenu add: 'plug all to model slots' translated action: #plugAllToSlots. aCustomMenu addLine. aCustomMenu add: 'plug mouseDown to model' translated action: #plugMouseDownToModel. aCustomMenu add: 'plug mouseMove to model' translated action: #plugMouseMoveToModel. aCustomMenu add: 'plug all to model' translated action: #plugAllToModel. aCustomMenu addLine. aCustomMenu add: 'set target...' translated action: #setTarget. aCustomMenu add: 'set mouseDown selector...' translated action: #setMouseDownSelector. aCustomMenu add: 'set mouseMove selector...' translated action: #setMouseMoveSelector. aCustomMenu add: 'set mouseUp selector...' translated action: #setMouseUpSelector. ! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! anyButtonPressed "Answer true if any mouse button is being pressed." ^ buttons anyMask: self class anyButton! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! blueButtonPressed "Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^ buttons anyMask: self class blueButton! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! redButtonPressed "Answer true if the red mouse button is being pressed. This is the first mouse button." ^ buttons anyMask: self class redButton! ! !MouseEvent methodsFor: 'button state' stamp: 'NS 5/19/2003 15:17'! yellowButtonPressed "Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^ buttons anyMask: self class yellowButton! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! anyButton ^ 7! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! blueButton ^ 1! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! redButton ^ 4! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! yellowButton ^ 2! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sw 2/17/2002 04:35'! pluggableYellowButtonActivity: shiftKeyState "Invoke the model's popup menu." | menu | (menu _ self getPluggableYellowButtonMenu: shiftKeyState) ifNil: [sensor waitNoButton] ifNotNil: [self terminateAndInitializeAround: [menu invokeOn: model orSendTo: self]]! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sw 3/22/2001 12:03'! shiftedTextPaneMenuRequest "The user chose the more... branch from the text-pane menu." ^ self pluggableYellowButtonActivity: true! ! !MouseMoveEvent methodsFor: '*nebraska-Morphic-Remote' stamp: 'dgd 2/22/2003 19:01'! decodeFromStringArray: array "decode the receiver from an array of strings" type := array first asSymbol. position := CanvasDecoder decodePoint: (array second). buttons := CanvasDecoder decodeInteger: (array third). startPoint := CanvasDecoder decodePoint: (array fourth)! ! !MouseOverHandler methodsFor: 'event handling' stamp: 'dgd 2/21/2003 23:00'! processMouseOver: anEvent "Re-establish the z-order for all morphs wrt the given event" | hand localEvt focus evt | hand := anEvent hand. leftMorphs := mouseOverMorphs asIdentitySet. "Assume some coherence for the number of objects in over list" overMorphs := WriteStream on: (Array new: leftMorphs size). enteredMorphs := WriteStream on: #(). "Now go looking for eventual mouse overs" hand handleEvent: anEvent asMouseOver. "Get out early if there's no change" (leftMorphs isEmpty and: [enteredMorphs position = 0]) ifTrue: [^leftMorphs := enteredMorphs := overMorphs := nil]. focus := hand mouseFocus. "Send #mouseLeave as appropriate" evt := anEvent asMouseLeave. "Keep the order of the left morphs by recreating it from the mouseOverMorphs" leftMorphs size > 1 ifTrue: [leftMorphs := mouseOverMorphs select: [:m | leftMorphs includes: m]]. leftMorphs do: [:m | (m == focus or: [m hasOwner: focus]) ifTrue: [localEvt := evt transformedBy: (m transformedFrom: hand). m handleEvent: localEvt] ifFalse: [overMorphs nextPut: m]]. "Send #mouseEnter as appropriate" evt := anEvent asMouseEnter. enteredMorphs ifNil: ["inform: was called in handleEvent:" ^leftMorphs := enteredMorphs := overMorphs := nil]. enteredMorphs := enteredMorphs contents. enteredMorphs reverseDo: [:m | (m == focus or: [m hasOwner: focus]) ifTrue: [localEvt := evt transformedBy: (m transformedFrom: hand). m handleEvent: localEvt]]. "And remember the over list" overMorphs ifNil: ["inform: was called in handleEvent:" ^leftMorphs := enteredMorphs := overMorphs := nil]. mouseOverMorphs := overMorphs contents. leftMorphs := enteredMorphs := overMorphs := nil! ! !MouseOverMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:40'! handlesMouseOver: evt ^model notNil! ! !MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:09'! addMorphsTo: morphList pianoRoll: pianoRoll eventTime: t betweenTime: leftTime and: rightTime "This code handles both the start and end morphs." | startX endX h delta | self startTime > rightTime ifTrue: [^self "Start time has not come into view."]. self endTime < leftTime ifTrue: [^self "End time has passed out of view."]. startX := pianoRoll xForTime: self startTime. endX := pianoRoll xForTime: self endTime. h := self colorMargin. "Height of highlight bar over thumbnails." morphList add: (self align: self bottomLeft with: startX @ (pianoRoll bottom - pianoRoll borderWidth - h)). morphList add: (endMorph align: endMorph bounds rightCenter with: endX @ self center y). morphList add: (self colorMorph bounds: (self topLeft - (0 @ h) corner: endMorph right @ (self bottom + h))). (soundTrackMorph isNil and: [moviePlayerMorph scorePlayer isNil]) ifFalse: ["Wants a sound track" (soundTrackMorph isNil or: [pianoRoll timeScale ~= soundTrackTimeScale]) ifTrue: ["Needs a new sound track" self buildSoundTrackMorphFor: pianoRoll]. morphList add: (soundTrackMorph align: soundTrackMorph bottomLeft with: colorMorph topLeft). self soundTrackOnBottom ifTrue: [soundTrackMorph align: soundTrackMorph bottomLeft with: self bottomLeft. delta := 0 @ self soundTrackHeight. self position: self position - delta. endMorph position: endMorph position - delta. colorMorph position: colorMorph position - delta]]! ! !MovieClipStartMorph methodsFor: 'piano rolls' stamp: 'dgd 2/22/2003 14:09'! resetFrom: scorePlayer (movieClipPlayer cueMorph isNil or: [self startTime < movieClipPlayer cueMorph startTime]) ifTrue: [movieClipPlayer openFileNamed: movieClipFileName withScorePlayer: soundTrackPlayerReady copy andPlayFrom: frameNumber; setCueMorph: self; step; pauseFrom: scorePlayer]! ! !MovieFrameSyncMorph methodsFor: 'piano rolls' stamp: 'dgd 2/21/2003 22:58'! encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick "Set frame number and milliseconds since start in case of drift" | next | moviePlayerMorph frameNumber: frameNumber msSinceStart: scorePlayer millisecondsSinceStart. "If there is a later sync point, set the appropriate frame rate until then." (next := self nextSyncEventAfter: index inTrack: track) isNil ifFalse: [moviePlayerMorph msPerFrame: (next time - ticks) * secsPerTick * 1000.0 / (next morph frameNumber - self frameNumber)]! ! !MovieMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:47'! drawOn: aCanvas | frame | frame := self currentFrame. frame notNil ifTrue: [^frame drawOn: aCanvas] ifFalse: [^super drawOn: aCanvas]! ! !MovieMorph methodsFor: 'geometry testing' stamp: 'dgd 2/22/2003 18:48'! containsPoint: p | frame | frame := self currentFrame. ^ (frame notNil and: [playMode = #stop]) ifTrue: [frame containsPoint: p] ifFalse: [super containsPoint: p]! ! !MovieMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 1 g: 0 b: 1! ! !MovieMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:47'! initialize "initialize the state of the receiver" super initialize. "" playMode _ #stop. "#stop, #playOnce, or #loop" msecsPerFrame _ 200. rotationDegrees _ 0. scalePoint _ 1.0 @ 1.0. frameList _ EmptyArray. currentFrameIndex _ 1. dwellCount _ 0! ! !MovieMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 09:59'! addCustomMenuItems: aCustomMenu hand: aHandMorph | movies subMenu | super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. subMenu _ MenuMorph new defaultTarget: self. frameList size > 1 ifTrue: [ subMenu add: 'repaint' translated action: #editDrawing. subMenu add: 'set rotation center' translated action: #setRotationCenter. subMenu add: 'play once' translated action: #playOnce. subMenu add: 'play loop' translated action: #playLoop. subMenu add: 'stop playing' translated action: #stopPlaying. currentFrameIndex > 1 ifTrue: [ subMenu add: 'previous frame' translated action: #previousFrame]. currentFrameIndex < frameList size ifTrue: [ subMenu add: 'next frame' translated action: #nextFrame]]. subMenu add: 'extract this frame' translated action: #extractFrame:. movies _ (self world rootMorphsAt: aHandMorph targetOffset) select: [:m | (m isKindOf: MovieMorph) or: [m isSketchMorph]]. (movies size > 1) ifTrue: [subMenu add: 'insert into movie' translated action: #insertIntoMovie:]. aCustomMenu add: 'movie...' translated subMenu: subMenu ! ! !MovieMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 18:47'! editDrawing | frame | frame := self currentFrame. frame notNil ifTrue: [frame editDrawingIn: self pasteUpMorph forBackground: false]! ! !MovieMorph methodsFor: 'menu' stamp: 'nk 6/12/2004 09:59'! insertIntoMovie: evt | movies aTarget | movies _ (self world rootMorphsAt: evt hand targetOffset) select: [:m | ((m isKindOf: MovieMorph) or: [m isSketchMorph]) and: [m ~= self]]. movies isEmpty ifTrue: [^ self]. aTarget _ movies first. (aTarget isSketchMorph) ifTrue: [aTarget _ aTarget replaceSelfWithMovie]. movies first insertFrames: frameList. self delete. ! ! !MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:03'! currentFrame frameList isEmpty ifTrue: [^nil]. currentFrameIndex := currentFrameIndex min: (frameList size). currentFrameIndex := currentFrameIndex max: 1. ^frameList at: currentFrameIndex! ! !MovieMorph methodsFor: 'private' stamp: 'jdl 3/28/2003 08:08'! setFrame: newFrameIndex | oldFrame p newFrame | oldFrame := self currentFrame. oldFrame ifNil: [^self]. self changed. p := oldFrame referencePosition. currentFrameIndex := newFrameIndex. currentFrameIndex := currentFrameIndex min: (frameList size). currentFrameIndex := currentFrameIndex max: 1. newFrame := frameList at: currentFrameIndex. newFrame referencePosition: p. oldFrame delete. self addMorph: newFrame. dwellCount := newFrame framesToDwell. self layoutChanged. self changed! ! !MoviePlayerMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 19:01'! position: newPos super position: newPos. (currentPage notNil and: [currentPage left odd]) ifTrue: ["crude word alignment for depth = 16" super position: newPos + (1 @ 0)]! ! !MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:07'! setInitialState super setInitialState. "" self layoutInset: 3. pageSize _ frameSize _ 200 @ 200. frameDepth _ 8. self disableDragNDrop! ! !MoviePlayerMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:22'! stopSoundTrackIfAny scorePlayer isNil ifTrue: [^self]. (scorePlayer isKindOf: SampledSound) ifTrue: [scorePlayer endGracefully] ifFalse: [scorePlayer := nil]! ! !MoviePlayerMorph methodsFor: 'menu' stamp: 'dgd 2/22/2003 13:21'! addSoundTrack | fileName | fileName := Utilities chooseFileWithSuffixFromList: #('.aif' '.wav') withCaption: 'Choose a sound track file'. fileName isNil ifTrue: [^self]. soundTrackFileName := fileName. self tryToShareScoreFor: soundTrackFileName. scorePlayer ifNil: [('*aif' match: fileName) ifTrue: [scorePlayer := SampledSound fromAIFFfileNamed: fileName]. ('*wav' match: fileName) ifTrue: [scorePlayer := SampledSound fromWaveFileNamed: fileName]]. soundTrackForm ifNotNil: ["Compute new soundTrack if we're showing it." self showHideSoundTrack; showHideSoundTrack]! ! !MoviePlayerMorph methodsFor: 'menu' stamp: 'dgd 10/8/2003 19:32'! invokeBookMenu "Invoke the book's control panel menu." | aMenu | aMenu _ MVCMenuMorph new defaultTarget: self. aMenu add: 'make a new movie' translated action: #makeAMovie. aMenu add: 'open movie file' translated action: #openMovieFile. aMenu add: 'add sound track' translated action: #addSoundTrack. aMenu addLine. scorePlayer ifNotNil: [soundTrackForm isNil ifTrue: [aMenu add: 'show sound track' translated action: #showHideSoundTrack] ifFalse: [aMenu add: 'hide sound track' translated action: #showHideSoundTrack]]. aMenu add: 'make thumbnail' translated action: #thumbnailForThisPage. cueMorph ifNotNil: ["Should check if piano roll and score already have a start event prior to this time." aMenu add: 'end clip here' translated action: #endClipHere]. aMenu popUpEvent: self world activeHand lastEvent in: self world ! ! !MoviePlayerMorph methodsFor: 'navigation' stamp: 'md 12/12/2003 16:21'! goToPage: i currentPage ifNil: [self makeMyPage]. frameNumber _ i. playDirection _ 0. self startRunning; step. "will stop after first step" soundTrackMorph ifNotNilDo: [:m | m image fillWhite]. self stepSoundTrack. ! ! !MoviePlayerMorph methodsFor: 'page controls' stamp: 'di 10/16/2000 13:20'! fullControlSpecs ^ #( ( '·' invokeBookMenu 'Invoke menu') ( '<--' firstPage 'Go to first page') ( '<<' playReverse 'Play backward') ( '<-' previousPage 'Back one frame') ( '| |' stopPlay 'Stop playback') ( '->' nextPage 'Forward one frame') ( '>>' playForward 'Play forward') ( '-->' lastPage 'Go to final page') ( '<->' scanBySlider 'Scan by slider' 'menu') "Note extra spec 'menu' causes mousedown activation -- see makePageControlsFrom:" )! ! !MoviePlayerMorph methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:22'! startRunning | ms | (frameBufferIfScaled ifNil: [currentPage image]) unhibernate. movieFile := AsyncFile new open: (FileDirectory default fullNameFor: movieFileName) forWrite: false. movieFile primReadStart: movieFile fileHandle fPosition: (self filePosForFrameNo: frameNumber) count: self fileByteCountPerFrame. scorePlayer isNil ifTrue: [ms := Time millisecondClockValue. msAtStart := ms - ((frameNumber - 1) * msPerFrame). msAtLastSync := ms - msAtStart] ifFalse: [(playDirection > 0 and: [scorePlayer isKindOf: SampledSound]) ifTrue: [scorePlayer reset; playSilentlyUntil: (frameNumber - 1) * msPerFrame / 1000.0; initialVolume: 1.0. [scorePlayer resumePlaying. msAtLastSync := scorePlayer millisecondsSinceStart] forkAt: Processor userInterruptPriority]. msAtLastSync := scorePlayer millisecondsSinceStart]. frameAtLastSync := frameNumber! ! !MoviePlayerMorph methodsFor: 'stepping' stamp: 'dgd 2/22/2003 13:22'! step "NOTE: The movie player has two modes of play, depending on whether scorePlayer is nil or not. If scorePlayer is nil, then play runs according to the millisecond clock. If scorePlayer is not nil, then the scorePlayer is consulted for synchronization. If the movie is running ahead, then some calls on step will skip their action until the right time. If the movie is running behind, then the frame may advance by more than one to maintain synchronization." "ALSO: This player operates with overlapped disk i/o. This means that while one frame is being displayed, the next frame in sequence is being read into a disk buffer. The value of frameNumber corresponds to the frame currently visible." "This code may not work right for playing backwards right now. Single-step and backwards (dir <= 0) should just run open-loop." | byteCount simTime ms nextFrameNumber | movieFile isNil ifTrue: [^self]. scorePlayer isNil ifTrue: [(ms := Time millisecondClockValue) < msAtStart ifTrue: ["clock rollover" msAtStart := ms - (frameNumber * msPerFrame)]. simTime := ms - msAtStart] ifFalse: [simTime := scorePlayer millisecondsSinceStart]. playDirection > 0 ifTrue: [nextFrameNumber := frameAtLastSync + ((simTime - msAtLastSync) // msPerFrame). nextFrameNumber = frameNumber ifTrue: [((scorePlayer isKindOf: AbstractSound) and: [scorePlayer isPlaying not]) ifTrue: [^self stopRunning]. ^self]] ifFalse: [nextFrameNumber := playDirection < 0 ifTrue: [frameNumber - 1] ifFalse: [frameNumber]]. byteCount := self fileByteCountPerFrame. self stepSoundTrack. movieFile waitForCompletion. movieFile primReadResult: movieFile fileHandle intoBuffer: (frameBufferIfScaled ifNil: [currentPage image]) bits at: 1 count: byteCount // 4. frameBufferIfScaled ifNotNil: ["If this player has been shrunk, then we have to warp to the current page." (WarpBlt current toForm: currentPage image) sourceForm: frameBufferIfScaled; combinationRule: 3; cellSize: (playDirection = 0 ifTrue: ["Use smoothing if just stepping" 2] ifFalse: [1]); copyQuad: frameBufferIfScaled boundingBox innerCorners toRect: currentPage image boundingBox]. currentPage changed. frameNumber := nextFrameNumber. (playDirection = 0 or: [(playDirection > 0 and: [frameNumber >= frameCount]) or: [playDirection < 0 and: [frameNumber <= 1]]]) ifTrue: [^self stopRunning]. "Start the read operation for the next frame..." movieFile primReadStart: movieFile fileHandle fPosition: (self filePosForFrameNo: frameNumber) count: byteCount! ! !MoviePlayerMorph methodsFor: 'stepping' stamp: 'aoy 2/15/2003 21:45'! stepSoundTrack | x image timeInMillisecs | scorePlayer ifNil: [^self]. soundTrackForm ifNil: [^self]. timeInMillisecs := playDirection = 0 ifTrue: ["Stepping forward or back" (frameNumber - 1) * msPerFrame] ifFalse: ["Driven by sound track" scorePlayer millisecondsSinceStart]. x := timeInMillisecs / 1000.0 * scorePlayer originalSamplingRate // 250. image := soundTrackMorph image. image copy: (image boundingBox translateBy: (x - (image width // 2)) @ 0) from: soundTrackForm to: 0 @ 0 rule: Form over. soundTrackMorph changed! ! !MoviePlayerMorph methodsFor: 'private' stamp: 'md 10/26/2003 13:07'! pvtOpenFileNamed: fName "Private - open on the movie file iof the given name" | f w h d n m | self stopRunning. fName = movieFileName ifTrue: [^ self]. "No reopen necessary on same file" movieFileName _ fName. "Read movie file parameters from 128-byte header... (records follow as {N=int32, N words}*)" f _ (FileStream oldFileNamed: movieFileName) binary. f nextInt32. w _ f nextInt32. h _ f nextInt32. d _ f nextInt32. n _ f nextInt32. m _ f nextInt32. f close. pageSize _ frameSize _ w@h. frameDepth _ d. frameCount _ n. frameNumber _ 1. playDirection _ 0. msAtLastSync _ 0. msPerFrame _ m/1000.0. self makeMyPage. (SmalltalkImage current platformName = 'Mac OS') ifTrue:[ (SmalltalkImage current extraVMMemory < self fileByteCountPerFrame) ifTrue: [^ self inform: 'Playing movies in Squeak requires that extra memory be allocated for asynchronous file IO. This particular movie requires a buffer of ' , (self fileByteCountPerFrame printString) , ' bytes, but you only have ' , (SmalltalkImage current extraVMMemory printString) , ' allocated. You can evaluate ''SmalltalkImage current extraVMMemory'' to check your allocation, and ''SmalltalkImage current extraVMMemory: 485000'' or the like to increase your allocation. Note that raising your allocation in this way only marks your image as needing this much, so you must then save, quit, and start over again before you can run this movie. Good luck.']]. ! ! !MoviePlayerMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:59'! initialize FileList registerFileReader: self! ! !MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/6/2002 21:36'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'movie') | (suffix = '*') ifTrue: [ self services] ifFalse: [#()]! ! !MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'hg 8/3/2000 17:01'! openAsMovie: fullFileName "Open a MoviePlayerMorph on the given file (must be in .movie format)." (self new openFileNamed: fullFileName) openInWorld! ! !MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 2/17/2002 01:23'! serviceOpenAsMovie "Answer a service for opening a file as a movie" ^ SimpleServiceEntry provider: self label: 'open as movie' selector: #openAsMovie: description: 'open file as movie' buttonLabel: 'open'! ! !MoviePlayerMorph class methodsFor: 'fileIn/Out' stamp: 'sw 9/7/2004 18:21'! services "Formerly: answer a service for opening as a movie. Nowadays... no services" ^ #(). " ^ Array with: self serviceOpenAsMovie" ! ! !MoviePlayerMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'! unload FileList unregisterFileReader: self ! ! !MovingEyeMorph methodsFor: 'as yet unclassified' stamp: 'yo 2/15/2001 15:24'! irisPos: cp | a b theta x y | theta _ (cp - self center) theta. a _ inner width // 2. b _ inner height // 2. x _ a * (theta cos). y _ b * (theta sin). iris position: ((x@y) asIntegerPoint) + self center - (iris extent // 2).! ! !MovingEyeMorph methodsFor: 'geometry' stamp: 'yo 2/15/2001 15:59'! extent: aPoint super extent: aPoint. inner extent: (self extent * ((1.0@1.0)-IrisSize)) asIntegerPoint. iris extent: (self extent * IrisSize) asIntegerPoint. inner position: (self center - (inner extent // 2)) asIntegerPoint. ! ! !MovingEyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:42'! defaultColor "answer the default color/fill style for the receiver" ^ Color black! ! !MovingEyeMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:42'! initialize "initialize the state of the receiver" super initialize. "" inner _ EllipseMorph new. inner color: self color. inner extent: (self extent * (1.0 @ 1.0 - IrisSize)) asIntegerPoint. inner borderColor: self color. inner borderWidth: 0. "" iris _ EllipseMorph new. iris color: Color white. iris extent: (self extent * IrisSize) asIntegerPoint. "" self addMorphCentered: inner. inner addMorphCentered: iris. "" self extent: 26 @ 33! ! !MovingEyeMorph methodsFor: 'stepping and presenter' stamp: 'di 2/18/2001 00:10'! step | cp | cp _ self globalPointToLocal: World primaryHand position. (inner containsPoint: cp) ifTrue: [iris position: (cp - (iris extent // 2))] ifFalse: [self irisPos: cp]. self changed "cover up gribblies if embedded in Flash"! ! !MovingEyeMorph methodsFor: 'testing' stamp: 'yo 2/15/2001 15:38'! stepTime ^ 100.! ! !MovingEyeMorph class methodsFor: 'class initialization' stamp: 'yo 2/15/2001 16:04'! initialize " MovingEyeMorph initialize " IrisSize _ (0.42@0.50).! ! !MovingEyeMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:51'! descriptionForPartsBin ^ self partName: 'MovingEye' categories: #('Demo') documentation: 'An eye which follows the cursor'! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! ascii isBinary _ false ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! binary isBinary _ true ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'nk 8/2/2004 17:02'! converter converter ifNil: [converter _ self class defaultConverter]. ^ converter ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 8/7/2003 09:12'! converter: aConverter converter _ aConverter. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:25'! isBinary ^ isBinary! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 16:33'! text isBinary _ false ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 7/30/2004 06:59'! contents | ret state | state _ converter saveStateOf: self. ret _ self upToEnd. converter restoreStateOf: self with: state. ^ ret. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:39'! next | n | n _ self converter nextFromStream: self. n ifNil: [^ nil]. isBinary and: [n isCharacter ifTrue: [^ n asciiValue]]. ^ n. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/12/2002 04:28'! next: anInteger | multiString | "self halt." self isBinary ifTrue: [^ (super next: anInteger) asByteArray]. multiString _ MultiString new: anInteger. 1 to: anInteger do: [:index | | character | (character _ self next) ifNotNil: [ multiString at: index put: character ] ifNil: [ multiString _ multiString copyFrom: 1 to: index - 1. ^ multiString ] ]. ^ multiString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:05'! nextDelimited: terminator | out ch pos | out _ WriteStream on: (String new: 1000). self atEnd ifTrue: [^ '']. pos _ self position. self next = terminator ifFalse: [ "absorb initial terminator" self position: pos. ]. [(ch _ self next) == nil] whileFalse: [ (ch = terminator) ifTrue: [ self peek = terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! nextMatchAll: aColl | save | save _ converter saveStateOf: self. aColl do: [:each | (self next) = each ifFalse: [ converter restoreStateOf: self with: save. ^ false. ]. ]. ^ true. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'! nextPut: aCharacter aCharacter isInteger ifTrue: [^ super nextPut: aCharacter asCharacter]. ^ self converter nextPut: aCharacter toStream: self ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! nextPutAll: aCollection self isBinary ifTrue: [ ^ super nextPutAll: aCollection. ]. aCollection do: [:e | self nextPut: e]. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/14/2002 13:54'! padToEndWith: aChar "We don't have pages, so we are at the end, and don't need to pad."! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next pos | self atEnd ifTrue: [^ nil]. pos _ self position. next _ self next. self position: pos. ^ next. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:25'! peekFor: item | next state | "self atEnd ifTrue: [^ false]. -- SFStream will give nil" state _ converter saveStateOf: self. (next _ self next) == nil ifTrue: [^ false]. item = next ifTrue: [^ true]. converter restoreStateOf: self with: state. ^ false. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'nk 7/29/2004 12:02'! reset super reset. isBinary ifNil: [isBinary _ false]. collection class == ByteArray ifTrue: ["Store as String and convert as needed." collection _ collection asString. isBinary _ true]. self converter. "ensure that we have a converter."! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'! skipSeparators [self atEnd] whileFalse: [ self basicNext isSeparator ifFalse: [ ^ self position: self position - 1]] ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 12/25/2003 16:04'! skipSeparatorsAndPeekNext "A special function to make nextChunk fast" | peek pos | [self atEnd] whileFalse: [ pos _ self position. (peek _ self next) isSeparator ifFalse: [ self position: pos. ^ peek. ]. ]. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 13:24'! upTo: delim | out ch | out _ WriteStream on: (String new: 1000). self atEnd ifTrue: [^ '']. [(ch _ self next) isNil] whileFalse: [ (ch = delim) ifTrue: [ ^ out contents "terminator is not doubled; we're done!!" ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteBinaryOrTextStream methodsFor: 'public' stamp: 'yo 11/11/2002 16:17'! upToEnd | newStream element newCollection | newCollection _ self isBinary ifTrue: [ByteArray new: 100] ifFalse: [String new: 100]. newStream _ WriteStream on: newCollection. [(element _ self next) notNil] whileTrue: [newStream nextPut: element]. ^ newStream contents ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 16:01'! basicNext ^ super next ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'md 10/20/2004 15:32'! basicNext: anInteger ^ super next: anInteger. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNext: n into: aString ^ super next: n into: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPeek ^ super peek ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPosition ^ super position. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPosition: pos ^ super position: pos. ! ! !MultiByteBinaryOrTextStream methodsFor: 'converting' stamp: 'yo 11/11/2002 13:16'! asBinaryOrTextStream ^ self ! ! !MultiByteBinaryOrTextStream methodsFor: 'private' stamp: 'nk 8/2/2004 17:01'! guessConverter ^ (self originalContents includesSubString: (ByteArray withAll: {27. 36}) asString) ifTrue: [CompoundTextConverter new] ifFalse: [self class defaultConverter ]! ! !MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 8/17/2004 10:02'! fileIn self setConverterForCode. super fileIn. ! ! !MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 11/11/2002 16:31'! fileInObjectAndCode "This file may contain: 1) a fileIn of code 2) just an object in SmartReferenceStream format 3) both code and an object. File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" | refStream object | self text. self peek asciiValue = 4 ifTrue: [ "pure object file" self binary. refStream _ SmartRefStream on: self. object _ refStream nextAndClose] ifFalse: [ "objects mixed with a fileIn" self fileIn. "reads code and objects, then closes the file" self binary. object _ SmartRefStream scannedObject]. "set by side effect of one of the chunks" SmartRefStream scannedObject: nil. "clear scannedObject" ^ object! ! !MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'tak 1/12/2005 13:47'! fileOutClass: extraClass andObject: theObject UTF8TextConverter writeBOMOn: self. ^ super fileOutClass: extraClass andObject: theObject! ! !MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 8/18/2004 09:36'! setConverterForCode | current | current _ converter saveStateOf: self. self position: 0. self binary. ((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [ self converter: UTF8TextConverter new ] ifFalse: [ self converter: MacRomanTextConverter new. ]. converter restoreStateOf: self with: current. self text. ! ! !MultiByteBinaryOrTextStream methodsFor: 'fileIn/Out' stamp: 'yo 7/7/2004 09:43'! setEncoderForSourceCodeNamed: streamName | l | l _ streamName asLowercase. " ((l endsWith: FileStream multiCs) or: [ (l endsWith: FileStream multiSt) or: [ (l endsWith: (FileStream multiSt, '.gz')) or: [ (l endsWith: (FileStream multiCs, '.gz'))]]]) ifTrue: [ self converter: UTF8TextConverter new. ^ self. ]. " ((l endsWith: FileStream cs) or: [ (l endsWith: FileStream st) or: [ (l endsWith: (FileStream st, '.gz')) or: [ (l endsWith: (FileStream cs, '.gz'))]]]) ifTrue: [ self converter: MacRomanTextConverter new. ^ self. ]. self converter: UTF8TextConverter new. ! ! !MultiByteBinaryOrTextStream methodsFor: 'properties-setting' stamp: 'yo 11/14/2002 13:49'! setFileTypeToObject "do nothing. We don't have a file type"! ! !MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:10'! fileInObjectAndCodeForProject "This file may contain: 1) a fileIn of code 2) just an object in SmartReferenceStream format 3) both code and an object. File it in and return the object. Note that self must be a FileStream or RWBinaryOrTextStream. Maybe ReadWriteStream incorporate RWBinaryOrTextStream?" | refStream object | self text. self peek asciiValue = 4 ifTrue: [ "pure object file" self binary. refStream _ SmartRefStream on: self. object _ refStream nextAndClose] ifFalse: [ "objects mixed with a fileIn" self fileInProject. "reads code and objects, then closes the file" self binary. object _ SmartRefStream scannedObject]. "set by side effect of one of the chunks" SmartRefStream scannedObject: nil. "clear scannedObject" ^ object! ! !MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'! fileInProject self setConverterForCodeForProject. super fileIn. ! ! !MultiByteBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:46'! setConverterForCodeForProject self converter: UTF8TextConverter new. ! ! !MultiByteBinaryOrTextStream commentStamp: '<historical>' prior: 0! It is similar to MultiByteFileStream, but works on in memory stream.! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ykoubo 9/28/2003 19:59'! on: aCollection encoding: encodingName | aTextConverter | encodingName isNil ifTrue: [aTextConverter _ TextConverter default] ifFalse: [aTextConverter _ TextConverter newForEncoding: encodingName]. ^ (self on: aCollection) converter: aTextConverter! ! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'yo 11/23/2003 20:32'! with: aCollection encoding: encodingName | aTextConverter | encodingName isNil ifTrue: [aTextConverter _ TextConverter default] ifFalse: [aTextConverter _ TextConverter newForEncoding: encodingName]. ^ (self with: aCollection) converter: aTextConverter! ! !MultiByteBinaryOrTextStream class methodsFor: 'defaults' stamp: 'nk 8/2/2004 17:01'! defaultConverter ^TextConverter defaultSystemConverter! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'! ascii super ascii. self detectLineEndConvention. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:57'! binary super binary. lineEndConvention _ nil. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/18/2003 15:11'! converter converter ifNil: [converter _ TextConverter defaultSystemConverter]. ^ converter ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/28/2002 11:09'! converter: aConverter converter _ aConverter. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/6/2003 11:56'! fileInEncodingName: aString self converter: (TextConverter newForEncoding: aString). super fileIn. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nk 9/5/2004 12:57'! lineEndConvention ^lineEndConvention! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 02:59'! lineEndConvention: aSymbol lineEndConvention _ aSymbol. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 2/21/2004 04:24'! wantsLineEndConversion: aBoolean wantsLineEndConversion _ aBoolean. self detectLineEndConvention.! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:49'! next | char secondChar state | char _ self converter nextFromStream: self. self doConversion ifTrue: [ char == Cr ifTrue: [ state _ converter saveStateOf: self. secondChar _ self bareNext. secondChar ifNotNil: [secondChar == Lf ifFalse: [converter restoreStateOf: self with: state]]. ^Cr]. char == Lf ifTrue: [^Cr]. ]. ^ char. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 7/31/2004 18:03'! next: anInteger | multiString | self isBinary ifTrue: [^ super next: anInteger]. multiString _ String new: anInteger. 1 to: anInteger do: [:index | | character | (character _ self next) ifNotNil: [ multiString at: index put: character ] ifNil: [ multiString _ multiString copyFrom: 1 to: index - 1. self doConversion ifFalse: [ ^ multiString ]. ^ self next: anInteger innerFor: multiString. ] ]. self doConversion ifFalse: [ ^ multiString ]. multiString _ self next: anInteger innerFor: multiString. (multiString size = anInteger or: [self atEnd]) ifTrue: [ ^ multiString]. ^ multiString, (self next: anInteger - multiString size). ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:26'! nextDelimited: terminator | out ch save | out _ WriteStream on: (String new: 1000). self atEnd ifTrue: [^ '']. save _ converter saveStateOf: self. self next = terminator ifFalse: [ "absorb initial terminator" converter restoreStateOf: self with: save. ]. [(ch _ self next) == nil] whileFalse: [ (ch = terminator) ifTrue: [ self peek = terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:13'! nextMatchAll: aColl | save | save _ converter saveStateOf: self. aColl do: [:each | (self next) = each ifFalse: [ converter restoreStateOf: self with: save. ^ false. ]. ]. ^ true. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 03:42'! nextPut: aCharacter aCharacter isInteger ifTrue: [^ super nextPut: aCharacter]. self doConversion ifTrue: [ aCharacter = Cr ifTrue: [ (LineEndStrings at: lineEndConvention) do: [:e | converter nextPut: e toStream: self]. ] ifFalse: [ converter nextPut: aCharacter toStream: self ]. ^ aCharacter ]. ^ self converter nextPut: aCharacter toStream: self ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 5/23/2003 09:40'! nextPutAll: aCollection (self isBinary or: [aCollection class == ByteArray]) ifTrue: [ ^ super nextPutAll: aCollection. ]. aCollection do: [:e | self nextPut: e]. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:00'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next save | self atEnd ifTrue: [^ nil]. save _ converter saveStateOf: self. next _ self next. converter restoreStateOf: self with: save. ^ next. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:15'! peekFor: item | next state | "self atEnd ifTrue: [^ false]. -- SFStream will give nil" state _ converter saveStateOf: self. (next _ self next) == nil ifTrue: [^ false]. item = next ifTrue: [^ true]. converter restoreStateOf: self with: state. ^ false. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/24/2004 13:35'! skipSeparators | state | [self atEnd] whileFalse: [ state _ converter saveStateOf: self. self next isSeparator ifFalse: [ ^ converter restoreStateOf: self with: state]] " [self atEnd] whileFalse: [ self next isSeparator ifFalse: [ ^ self position: self position - converter currentCharSize. ]. ]. " ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 2/21/2004 04:01'! skipSeparatorsAndPeekNext "A special function to make nextChunk fast" | peek save | [self atEnd] whileFalse: [ save _ converter saveStateOf: self. (peek _ self next) isSeparator ifFalse: [ converter restoreStateOf: self with: save. ^ peek. ]. ]. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/28/2002 11:17'! upTo: delim | out ch | out _ WriteStream on: (String new: 1000). self atEnd ifTrue: [^ '']. [(ch _ self next) isNil] whileFalse: [ (ch = delim) ifTrue: [ ^ out contents "terminator is not doubled; we're done!!" ]. out nextPut: ch. ]. ^ out contents. ! ! !MultiByteFileStream methodsFor: 'public' stamp: 'yo 8/30/2002 16:39'! upToEnd | newStream element | collection _ self isBinary ifTrue: [ByteArray new: 100] ifFalse: [String new: 100]. newStream _ WriteStream on: collection. [(element _ self next) notNil] whileTrue: [newStream nextPut: element]. ^ newStream contents ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:38'! bareNext ^ self converter nextFromStream: self. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'! convertStringFromCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf]. "lineEndConvention == #crlf" inStream _ ReadStream on: aString. outStream _ WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPutAll: CrLf]]. ^ outStream contents! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 02:56'! convertStringToCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr]. "lineEndConvention == #crlf" inStream _ ReadStream on: aString. outStream _ WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPut: Cr. inStream peek = Lf ifTrue: [inStream next]]]. ^ outStream contents! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:50'! detectLineEndConvention "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." | char numRead state | self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. self wantsLineEndConversion ifFalse: [^ lineEndConvention _ nil.]. self closed ifTrue: [^ lineEndConvention _ LineEndDefault.]. "Default if nothing else found" numRead _ 0. state _ converter saveStateOf: self. lineEndConvention _ nil. [super atEnd not and: [numRead < LookAheadCount]] whileTrue: [char _ self next. char = Lf ifTrue: [converter restoreStateOf: self with: state. ^ lineEndConvention _ #lf]. char = Cr ifTrue: [self peek = Lf ifTrue: [lineEndConvention _ #crlf] ifFalse: [lineEndConvention _ #cr]. converter restoreStateOf: self with: state. ^ lineEndConvention]. numRead _ numRead + 1]. converter restoreStateOf: self with: state. ^ lineEndConvention _ LineEndDefault. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'nk 9/5/2004 12:51'! doConversion ^self wantsLineEndConversion and: [ lineEndConvention notNil ]! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:44'! next: n innerFor: aString | peekChar state | "if we just read a CR, and the next character is an LF, then skip the LF" aString size = 0 ifTrue: [^ aString]. (aString last = Character cr) ifTrue: [ state _ converter saveStateOf: self. peekChar _ self bareNext. "super peek doesn't work because it relies on #next" (peekChar notNil and: [peekChar ~= Character lf]) ifTrue: [ converter restoreStateOf: self with: state. ]. ]. ^ aString withSqueakLineEndings. ! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/21/2004 03:51'! wantsLineEndConversion ^ wantsLineEndConversion ifNil: [false]. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'md 10/17/2004 16:09'! basicNext: anInteger ^ super next: anInteger. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNext: n into: aString ^ super next: n into: aString. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicPeek ^ super peek ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition ^ super position. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition: pos ^ super position: pos. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicReadInto: byteArray startingAt: startIndex count: count ^ super readInto: byteArray startingAt: startIndex count: count. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSetToEnd ^ super setToEnd. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSkip: n ^ super skip: n. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicUpTo: delim ^ super upTo: delim. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:09'! basicVerbatim: aString ^ super verbatim: aString. ! ! !MultiByteFileStream methodsFor: 'open/close' stamp: 'nk 7/30/2004 17:59'! open: fileName forWrite: writeMode | result | result := super open: fileName forWrite: writeMode. result ifNotNil: [converter ifNil: [self localName = (FileDirectory localNameFor: SmalltalkImage current sourcesName) ifTrue: [converter := MacRomanTextConverter new] ifFalse: [converter := UTF8TextConverter new]]. self detectLineEndConvention]. ^result! ! !MultiByteFileStream methodsFor: 'open/close' stamp: 'yo 8/13/2003 13:51'! reset super reset. converter ifNil: [ converter _ UTF8TextConverter new. ]. ! ! !MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:06'! accepts: aSymbol ^ converter accepts: aSymbol. ! ! !MultiByteFileStream methodsFor: 'remnant' stamp: 'yo 8/28/2002 11:09'! filterFor: aFileStream | rw | name _ aFileStream name. rw _ aFileStream isReadOnly not. aFileStream close. self open: name forWrite: rw. ^self. ! ! !MultiByteFileStream methodsFor: 'private' stamp: 'mir 8/25/2004 17:27'! setConverterForCode | current | (SourceFiles at: 2) ifNotNil: [self fullName = (SourceFiles at: 2) fullName ifTrue: [^ self]]. current _ self converter saveStateOf: self. self position: 0. self binary. ((self next: 3) = (ByteArray with: 16rEF with: 16rBB with: 16rBF)) ifTrue: [ self converter: UTF8TextConverter new ] ifFalse: [ self converter: MacRomanTextConverter new. ]. converter restoreStateOf: self with: current. self text. ! ! !MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'yo 8/17/2004 10:03'! fileIn self setConverterForCode. super fileIn. ! ! !MultiByteFileStream methodsFor: 'fileIn/Out' stamp: 'tak 1/12/2005 14:48'! fileOutClass: extraClass andObject: theObject self binary. UTF8TextConverter writeBOMOn: self. self text. ^ super fileOutClass: extraClass andObject: theObject! ! !MultiByteFileStream commentStamp: '<historical>' prior: 0! The central class to access the external file. The interface of this object is similar to good old StandardFileStream, but internally it asks the converter, which is a sub-instance of TextConverter, and do the text conversion. It also combined the good old CrLfFileStream. CrLfFileStream class>>new now returns an instance of MultiByteFileStream. There are several pitfalls: * You always have to be careful about the binary/text distinction. In #text mode, it usually interpret the bytes. * A few file pointer operations treat the file as uninterpreted byte no matter what. This means that if you use 'fileStream skip: -1', 'fileStream position: x', etc. in #text mode, the file position can be in the middle of multi byte character. If you want to implement some function similar to #peek for example, call the saveStateOf: and restoreStateOf: methods to be able to get back to the original state. * #lineEndConvention: and #wantsLineEndConversion: (and #binary) can cause some puzzling situation because the inst var lineEndConvention and wantsLineEndConversion are mutated. If you have any suggestions to clean up the protocol, please let me know.! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'! defaultToCR "MultiByteFileStream defaultToCR" LineEndDefault := #cr. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'! defaultToCRLF "MultiByteFileStream defaultToCRLF" LineEndDefault := #crlf.! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:46'! defaultToLF "MultiByteFileStream defaultToLF" LineEndDefault := #lf. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'! guessDefaultLineEndConvention "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR]. FileDirectory pathNameDelimiter = $/ ifTrue:[^self defaultToLF]. FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF]. "in case we don't know" ^self defaultToCR. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'! initialize "MultiByteFileStream initialize" Cr := Character cr. Lf := Character lf. CrLf := String with: Cr with: Lf. LineEndStrings := Dictionary new. LineEndStrings at: #cr put: (String with: Character cr). LineEndStrings at: #lf put: (String with: Character lf). LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). LookAheadCount := 2048. Smalltalk addToStartUpList: self. self startUp. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:44'! startUp self guessDefaultLineEndConvention. ! ! !MultiByteFileStream class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:43'! newFrom: aFileStream | rw n | n _ aFileStream name. rw _ aFileStream isReadOnly not. aFileStream close. ^self new open: n forWrite: rw. ! ! !MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'! doesDisplaying ^false "it doesn't do displaying using copyBits"! ! !MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 1/6/2005 23:00'! setFont foregroundColor ifNil: [foregroundColor _ Color black]. super setFont. baselineY _ lineY + line baseline. destY _ baselineY - font ascent.! ! !MultiCanvasCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:55'! textColor: color foregroundColor _ color! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." lastIndex_ lastIndex + 1. ^false! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! crossedX "This condition will sometimes be reached 'legally' during display, when, for instance the space that caused the line to wrap actually extends over the right boundary. This character is allowed to display, even though it is technically outside or straddling the clipping ectangle since it is in the normal case not visible and is in any case appropriately clipped by the scanner." "self fillLeading." ^ true ! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! endOfRun "The end of a run in the display case either means that there is actually a change in the style (run code) to be associated with the string or the end of this line has been reached." | runLength | lastIndex = line last ifTrue: [^true]. runX _ destX. runLength _ text runLengthFor: (lastIndex _ lastIndex + 1). runStopIndex _ lastIndex + (runLength - 1) min: line last. self setStopConditions. ^ false! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount). lastIndex _ lastIndex + 1. ^ false! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (textStyle alignment = Justified ifTrue: [#paddedSpace]). ! ! !MultiCanvasCharacterScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:55'! tab destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastIndex _ lastIndex + 1. ^ false! ! !MultiCanvasCharacterScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 13:55'! canvas: aCanvas "set the canvas to draw on" canvas ifNotNil: [ self inform: 'initializing twice!!' ]. canvas _ aCanvas! ! !MultiCanvasCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:55'! displayLine: textLine offset: offset leftInRun: leftInRun | nowLeftInRun done startLoc startIndex stopCondition | "largely copied from DisplayScanner's routine" line _ textLine. foregroundColor ifNil: [ foregroundColor _ Color black ]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. rightMargin _ line rightMargin + offset x. lineY _ line top + offset y. lastIndex _ textLine first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. runX _ destX _ leftMargin. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. [done] whileFalse: [ "remember where this portion of the line starts" startLoc _ destX@destY. startIndex _ lastIndex. "find the end of this portion of the line" stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern "displaying: false". "display that portion of the line" canvas drawString: text string from: startIndex to: lastIndex at: startLoc font: font color: foregroundColor. "handle the stop condition" done _ self perform: stopCondition ]. ^runStopIndex - lastIndex! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 8/26/2002 11:08'! asCharacter ^ self isOctetCharacter ifTrue: [Character value: self asciiValue] ifFalse: [self]! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 8/26/2002 11:10'! asString ^MultiString with: self. ! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 12/2/2004 16:13'! asUnicode | table charset v | self leadingChar = 0 ifTrue: [^ value]. charset _ EncodedCharSet charsetAt: self leadingChar. charset isCharset ifFalse: [^ self charCode]. table _ charset ucsTable. table isNil ifTrue: [^ 16rFFFD]. v _ table at: self charCode + 1. v = -1 ifTrue: [^ 16rFFFD]. ^ v. ! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 12/2/2004 16:16'! asUnicodeChar | table charset v | self leadingChar = 0 ifTrue: [^ value]. charset _ EncodedCharSet charsetAt: self leadingChar. charset isCharset ifFalse: [^ self]. table _ charset ucsTable. table isNil ifTrue: [^ Character value: 16rFFFD]. v _ table at: self charCode + 1. v = -1 ifTrue: [^ Character value: 16rFFFD]. ^ MultiCharacter leadingChar: charset unicodeLeadingChar code: v. ! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 8/26/2002 11:10'! isoToSqueak ^ self. ! ! !MultiCharacter methodsFor: 'converting' stamp: 'yo 8/26/2002 11:11'! squeakToIso ^ self ! ! !MultiCharacter methodsFor: 'as yet unclassified' stamp: 'yo 8/26/2002 11:11'! value: anInteger value _ anInteger. ! ! !MultiCharacter methodsFor: 'testing' stamp: 'yo 3/17/2004 16:25'! isUnicode ^ ((EncodedCharSet charsetAt: self leadingChar) isKindOf: LanguageEnvironment class).! ! !MultiCharacter methodsFor: 'comparing' stamp: 'yo 9/2/2002 16:51'! = other ^(other isCharacter) and: [self asciiValue = other asciiValue]. ! ! !MultiCharacter methodsFor: 'comparing' stamp: 'yo 8/26/2002 11:12'! hash "Hash is reimplemented because = is implemented." ^ value ! ! !MultiCharacter methodsFor: 'printing' stamp: 'yo 8/5/2003 13:33'! hex ^ value hex. ! ! !MultiCharacter commentStamp: 'yo 10/19/2004 22:28' prior: 0! This class represents 32-bit wide characters. In practice, you don't want to go into negative values, so it uses 30-bit (another bit is used for the SmallInteger tag). The code point is based on Unicode. Since Unicode is 21-bit wide character set, we have several bits available for other information. As the Unicode Standard states, a Unicode code point doesn't carry the language information. This is going to be a problem with the languages so called CJK (Chinese, Japanese, Korean. Or often CJKV including Vietnamese). Since the characters of those languages are unified and given the same code point, it is impossible to display a bare Unicode code point in an inspector or such tools. To utilize the extra available bits, we use them for identifying the languages. Since the old implementation uses the bits to identify the character encoding, the bits are sometimes called "encoding tag" or neutrally "leading char", but the bits rigidly denotes the concept of languages. The other languages can have the language tag if you like. This will help to break the large default font (font set) into separately loadable chunk of fonts. However, it is open to the each native speakers and writers to decide how to define the character equality, since the same Unicode code point may have different language tag thus simple #= comparison may return false. ! !MultiCharacter class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:44'! allCharacters self shouldNotImplement. ! ! !MultiCharacter class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 11:45'! from: aCharacter ^ self value: aCharacter asciiValue. ! ! !MultiCharacter class methodsFor: 'instance creation' stamp: 'yo 12/30/2002 11:01'! leadingChar: leadChar code: code code >= 16r400000 ifTrue: [ self error: 'code is out of range'. ]. leadChar >= 256 ifTrue: [ self error: 'lead is out of range'. ]. ^self value: (leadChar bitShift: 22) + code. ! ! !MultiCharacter class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 16:39'! value: anInteger anInteger < 256 ifTrue: [^ Character value: anInteger]. ^ self basicNew value: anInteger. ! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'! characterBlockAtPoint: aPoint in: aParagraph "Answer a CharacterBlock for character in aParagraph at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the text's destination form rectangle and the composition rectangle." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterPoint _ aPoint. ^self buildCharacterBlockIn: aParagraph! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:36'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" | runLength lineStop done stopCondition | line := textLine. rightMargin := line rightMargin. lastIndex := line first. self setStopConditions. "also sets font" characterIndex := index. " == nil means scanning for point" characterPoint := aPoint. (characterPoint isNil or: [characterPoint y > line bottom]) ifTrue: [characterPoint := line bottomRight]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex notNil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. destX := leftMargin := line leftMarginForAlignment: alignment. destY := line top. runLength := text runLengthFor: line first. characterIndex ifNotNil: [lineStop := characterIndex "scanning for index"] ifNil: [lineStop := line last "scanning for point"]. runStopIndex := lastIndex + (runLength - 1) min: lineStop. lastCharacterExtent := 0 @ line lineHeight. spaceCount := 0. done := false. [done] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth ifNil: [font widthOf: (text at: lastIndex)] ifNotNil: [specialWidth]). (self perform: stopCondition) ifTrue: [characterIndex ifNil: [ "Result for characterBlockAtPoint: " (stopCondition ~~ #cr and: [ lastIndex == line last and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) ifTrue: [ "Correct for right half of last character in line" ^ (CharacterBlock new stringIndex: lastIndex + 1 text: text topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) extent: 0 @ lastCharacterExtent y) textLine: line ]. ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0)) textLine: line] ifNotNil: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent) textLine: line]]]! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'! characterBlockForIndex: targetIndex in: aParagraph "Answer a CharacterBlock for character in aParagraph at targetIndex. The coordinates in the CharacterBlock will be appropriate to the intersection of the destination form rectangle and the composition rectangle." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterIndex _ targetIndex. characterPoint _ aParagraph rightMarginForDisplay @ (aParagraph topAtLineIndex: (aParagraph lineIndexOfCharacterIndex: characterIndex)). ^self buildCharacterBlockIn: aParagraph! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin _ leftMargin. indentationLevel timesRepeat: [ nextLeftMargin _ textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin]! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:56'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth _ anchoredMorph width. ^ true! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'yo 8/6/2003 05:55'! scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | encoding f nextDestX maxAscii startEncoding char charValue | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. char _ (sourceString at: lastIndex). charValue _ char charCode. charValue > maxAscii ifTrue: [charValue _ maxAscii]. (encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [ ^ stops at: charValue + 1 ]. nextDestX _ destX + (self widthOf: char inFont: font). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'! buildCharacterBlockIn: para | lineIndex runLength lineStop done stopCondition | "handle nullText" (para numberOfLines = 0 or: [text size = 0]) ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" text: para text topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment])) @ para compositionRectangle top extent: 0 @ textStyle lineGrid]. "find the line" lineIndex _ para lineIndexOfTop: characterPoint y. destY _ para topAtLineIndex: lineIndex. line _ para lines at: lineIndex. rightMargin _ para rightMarginForDisplay. (lineIndex = para numberOfLines and: [(destY + line lineHeight) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" self characterPointSetX: rightMargin] ifFalse: [characterPoint y < (para compositionRectangle) top ifTrue: ["force search to first line" characterPoint _ (para compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [self characterPointSetX: rightMargin]]. destX _ (leftMargin _ para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])). nextLeftMargin_ para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]). lastIndex _ line first. self setStopConditions. "also sets font" runLength _ (text runLengthFor: line first). characterIndex == nil ifTrue: [lineStop _ line last "characterBlockAtPoint"] ifFalse: [lineStop _ characterIndex "characterBlockForIndex"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. lastCharacterExtent _ 0 @ line lineHeight. spaceCount _ 0. done _ false. self handleIndentation. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [characterIndex == nil ifTrue: ["characterBlockAtPoint" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent] ifFalse: ["characterBlockForIndex" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent]]]! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'! characterPointSetX: xVal characterPoint _ xVal @ characterPoint y! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'! lastCharacterExtentSetX: xVal lastCharacterExtent _ xVal @ lastCharacterExtent y! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:56'! lastSpaceOrTabExtentSetX: xVal lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 1/6/2005 22:55'! cr "Answer a CharacterBlock that specifies the current location of the mouse relative to a carriage return stop condition that has just been encountered. The ParagraphEditor convention is to denote selections by CharacterBlocks, sometimes including the carriage return (cursor is at the end) and sometimes not (cursor is in the middle of the text)." ((characterIndex ~= nil and: [characterIndex > text size]) or: [(line last = text size) and: [(destY + line lineHeight) < characterPoint y]]) ifTrue: ["When off end of string, give data for next character" destY _ destY + line lineHeight. baselineY _ line lineHeight. lastCharacter _ nil. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ destY. lastIndex _ lastIndex + 1. self lastCharacterExtentSetX: 0. ^ true]. lastCharacter _ CR. characterPoint _ destX @ destY. self lastCharacterExtentSetX: rightMargin - destX. ^true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex _ characterIndex. characterPoint _ (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter _ (text at: lastIndex). characterPoint _ destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter _ (text at: line last). characterPoint _ destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex _ lastIndex + 1. lastCharacter _ text at: lastIndex. currentX _ destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint _ currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1))). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab _ true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab _ false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'! endOfRun "Before arriving at the cursor location, the selection has encountered an end of run. Answer false if the selection continues, true otherwise. Set up indexes for building the appropriate CharacterBlock." | runLength lineStop | (((characterIndex ~~ nil and: [runStopIndex < characterIndex and: [runStopIndex < text size]]) or: [characterIndex == nil and: [lastIndex < line last]]) or: [ ((lastIndex < line last) and: [((text at: lastIndex) leadingChar ~= (text at: lastIndex+1) leadingChar) and: [lastIndex ~= characterIndex]])]) ifTrue: ["We're really at the end of a real run." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). characterIndex ~~ nil ifTrue: [lineStop _ characterIndex "scanning for index"] ifFalse: [lineStop _ line last "scanning for point"]. (runStopIndex _ lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex _ lineStop]. self setStopConditions. ^false]. lastCharacter _ text at: lastIndex. characterPoint _ destX @ destY. ((lastCharacter = Space and: [alignment = Justified]) or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent]. characterIndex ~~ nil ifTrue: ["If scanning for an index and we've stopped on that index, then we back destX off by the width of the character stopped on (it will be pointing at the right side of the character) and return" runStopIndex = characterIndex ifTrue: [self characterPointSetX: destX - lastCharacterExtent x. ^true]. "Otherwise the requested index was greater than the length of the string. Return string size + 1 as index, indicate further that off the string by setting character to nil and the extent to 0." lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "Scanning for a point and either off the end of the line or off the end of the string." runStopIndex = text size ifTrue: ["off end of string" lastIndex _ lastIndex + 1. lastCharacter _ nil. self lastCharacterExtentSetX: 0. ^true]. "just off end of line without crossing x" lastIndex _ lastIndex + 1. ^true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'! paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer whether the scanning has crossed the cursor." | pad | pad _ 0. spaceCount _ spaceCount + 1. pad _ line justifiedPadFor: spaceCount. lastSpaceOrTabExtent _ lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: spaceWidth + pad. (destX + lastSpaceOrTabExtent x) >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^self crossedX]. lastIndex _ lastIndex + 1. destX _ destX + lastSpaceOrTabExtent x. ^ false ! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'! setFont specialWidth _ nil. super setFont! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). ! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:56'! tab | currentX | currentX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastSpaceOrTabExtent _ lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy. ^ self crossedX]. destX _ currentX. lastIndex _ lastIndex + 1. ^false! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! addEmphasis: code "Set the bold-ital-under-strike emphasis." emphasisCode _ emphasisCode bitOr: code! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! addKern: kernDelta "Set the current kern amount." kern _ kern + kernDelta! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle text _ aParagraph text. textStyle _ aParagraph textStyle. ! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! setActualFont: aFont "Set the basal font to an isolated font reference." font _ aFont! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! setAlignment: style alignment _ style. ! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/19/2002 02:05'! setConditionArray: aSymbol aSymbol == #paddedSpace ifTrue: [^stopConditions _ PaddedSpaceCondition "copy"]. "aSymbol == #space ifTrue: [^stopConditions _ SpaceCondition copy]." aSymbol == nil ifTrue: [^stopConditions _ NilCondition "copy"]. self error: 'undefined stopcondition for space character'. ! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'tak 12/19/2004 15:45'! setFont | priorFont | "Set the font and other emphasis." priorFont _ font. text == nil ifFalse:[ emphasisCode _ 0. kern _ 0. indentationLevel _ 0. alignment _ textStyle alignment. font _ nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font _ font emphasized: emphasisCode. priorFont ifNotNil: [destX _ destX + priorFont descentKern]. destX _ destX - font descentKern. "NOTE: next statement should be removed when clipping works" leftMargin ifNotNil: [destX _ destX max: leftMargin]. kern _ kern - font baseKern. "Install various parameters from the font." spaceWidth _ font widthOf: Space. xTable _ font xTable. " map _ font characterToGlyphMap." stopConditions _ DefaultStopConditions.! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! text: t textStyle: ts text _ t. textStyle _ ts! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! textColor: ignored "Overridden in DisplayScanner"! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 13:53'! basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char | <primitive: 103> lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [char _ (sourceString at: lastIndex). ascii _ char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextDestX _ destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/30/2002 22:59'! combinableChar: char for: prevEntity ! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/20/2002 11:46'! isBreakableAt: index in: sourceString in: encodingClass ^ encodingClass isBreakableAt: index in: sourceString. ! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:03'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. "xTable _ f xTable. maxAscii _ xTable size - 2." spaceWidth _ f widthOf: Space. ] ifFalse: [ (font isMemberOf: HostFont) ifTrue: [ f _ font. maxAscii _ f maxAscii. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. ]. [lastIndex <= stopIndex] whileTrue: [ "self halt." encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [ self registerBreakableIndex. ]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops at: CrossedX]]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:09'! scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | charCode encoding f maxAscii startEncoding combining combined combiningIndex c | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. spaceWidth _ font widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. spaceWidth _ font widthOf: Space. ]. combining _ nil. [lastIndex <= stopIndex] whileTrue: [ charCode _ (sourceString at: lastIndex) charCode. c _ (sourceString at: lastIndex). combining ifNil: [ combining _ CombinedChar new. combining add: c. combiningIndex _ lastIndex. lastIndex _ lastIndex + 1. ] ifNotNil: [ (combining add: c) ifFalse: [ self addCharToPresentation: (combined _ combining combined). combining _ CombinedChar new. combining add: c. charCode _ combined charCode. encoding _ combined leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. (encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [ ^ stops at: charCode + 1 ] ifFalse: [ ^ stops at: EndOfRun ]. ]. charCode > maxAscii ifTrue: [charCode _ maxAscii]. "" (encoding = 0 and: [(stopConditions at: charCode + 1) ~~ nil]) ifTrue: [ combining ifNotNil: [ self addCharToPresentation: (combining combined). ]. ^ stops at: charCode + 1 ]. (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ self registerBreakableIndex. ]. destX > rightX ifTrue: [ destX ~= firstDestX ifTrue: [ lastIndex _ combiningIndex. self removeLastCharFromPresentation. ^ stops at: CrossedX]]. combiningIndex _ lastIndex. lastIndex _ lastIndex + 1. ] ifTrue: [ lastIndex _ lastIndex + 1. numOfComposition _ numOfComposition + 1. ]. ]. ]. lastIndex _ stopIndex. combining ifNotNil: [ combined _ combining combined. self addCharToPresentation: combined. "assuming that there is always enough space for at least one character". destX _ destX + (self widthOf: combined inFont: font). ]. ^ stops at: EndOfRun! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:08'! scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [ascii < stopConditions size and: [(stopConditions at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ self registerBreakableIndex. ]. nextDestX _ destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [destX ~= firstDestX ifTrue: [^ stops at: CrossedX]]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 3/16/2005 19:08'! scanMultiCharactersR2LFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Note that 'rightX' really means 'endX' in R2L context. Ie. rightX is usually smaller than destX." | ascii encoding f nextDestX maxAscii startEncoding | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. ascii _ (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii _ maxAscii]. (encoding = 0 and: [(stopConditions at: ascii + 1) ~~ nil]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ self registerBreakableIndex. ]. nextDestX _ destX - (font widthOf: (sourceString at: lastIndex)). nextDestX < rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX - kernDelta. lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! columnBreak ^true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! embeddedObject | savedIndex | savedIndex _ lastIndex. text attributesAt: lastIndex do:[:attr| attr anchoredMorph ifNotNil:[ "Following may look strange but logic gets reversed. If the morph fits on this line we're not done (return false for true) and if the morph won't fit we're done (return true for false)" (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]]. lastIndex _ savedIndex + 1. "for multiple(!!) embedded morphs" ^false! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! handleIndentation self indentationLevel timesRepeat: [ self plainTab]! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! indentationLevel "return the number of tabs that are currently being placed at the beginning of each line" ^indentationLevel ifNil:[0]! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! indentationLevel: anInteger "set the number of tabs to put at the beginning of each line" indentationLevel _ anInteger! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! leadingTab "return true if only tabs lie to the left" line first to: lastIndex do: [:i | (text at: i) == Tab ifFalse: [^ false]]. ^ true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 1/18/2005 08:08'! measureString: aString inFont: aFont from: startIndex to: stopIndex "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" destX _ destY _ lastIndex _ 0. baselineY _ aFont ascent. xTable _ aFont xTable. font := aFont. " added Dec 03, 2004 " " map _ aFont characterToGlyphMap." self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. ^destX! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." | w | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. destX _ destX + (w _ anchoredMorph width). (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. lastIndex _ lastIndex + 1. self setFont. "Force recalculation of emphasis for next run" ^ true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! plainTab "This is the basic method of adjusting destX for a tab." destX _ (alignment == Justified and: [self leadingTab not]) ifTrue: "embedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/27/2002 04:33'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | startEncoding selector | (sourceString isKindOf: String) ifTrue: [^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta.]. (sourceString isKindOf: MultiString) ifTrue: [ startIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. selector _ (EncodedCharSet charsetAt: startEncoding) scanSelector. ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stopConditions with: kernDelta). ]. ^ stops at: EndOfRun ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/3/2003 12:09'! addCharToPresentation: char ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 16:15'! registerBreakableIndex "Record left x and character index of the line-wrappable point. The default implementation here does nothing." ^ false. ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/23/2003 14:25'! removeLastCharFromPresentation ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/1/2003 10:43'! widthOf: char inFont: aFont (char isMemberOf: CombinedChar) ifTrue: [ ^ aFont widthOf: char base. ] ifFalse: [ ^ aFont widthOf: char. ]. ! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'! initialize destX _ destY _ leftMargin _ 0.! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'! initializeStringMeasurer stopConditions _ Array new: 258. stopConditions at: CrossedX put: #crossedX. stopConditions at: EndOfRun put: #endOfRun. ! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'yo 12/18/2002 13:53'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !MultiCharacterScanner class methodsFor: 'class initialization' stamp: 'yo 12/18/2002 14:09'! initialize " MultiCharacterScanner initialize " | a | a _ Array new: 258. a at: 1 + 1 put: #embeddedObject. a at: Tab asciiValue + 1 put: #tab. a at: CR asciiValue + 1 put: #cr. a at: EndOfRun put: #endOfRun. a at: CrossedX put: #crossedX. NilCondition _ a copy. DefaultStopConditions _ a copy. PaddedSpaceCondition _ a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. SpaceCondition _ a copy. SpaceCondition at: Space asciiValue + 1 put: #space. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 2/10/2004 23:00'! addCharToPresentation: char presentation nextPut: char. lastWidth _ self widthOf: char inFont: font. destX _ destX + lastWidth. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:38'! getPresentation ^ presentation contents. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:28'! getPresentationLine ^ presentationLine. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:51'! isBreakableAt: index in: sourceString in: encodingClass ^ encodingClass isBreakableAt: index in: sourceString. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 16:28'! registerBreakableIndex "Record left x and character index of the line-wrappable point. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." (text at: lastIndex) = Character space ifTrue: [ breakAtSpace _ true. spaceX _ destX. spaceCount _ spaceCount + 1. lineHeightAtBreak _ lineHeight. baselineAtBreak _ baseline. breakableIndex _ lastIndex. destX > rightMargin ifTrue: [^self crossedX]. ] ifFalse: [ breakAtSpace _ false. lineHeightAtBreak _ lineHeight. baselineAtBreak _ baseline. breakableIndex _ lastIndex - 1. ]. ^ false. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 2/10/2004 22:59'! removeLastCharFromPresentation presentation ifNotNil: [ presentation position: presentation position - 1. ]. destX _ destX - lastWidth. ! ! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! presentation ^ presentation. ! ! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! presentationLine ^ presentationLine. ! ! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 14:56'! rightX "Meaningful only when a line has just been composed -- refers to the line most recently composed. This is a subtrefuge to allow for easy resizing of a composition rectangle to the width of the maximum line. Useful only when there is only one line in the form or when each line is terminated by a carriage return. Handy for sizing menus and lists." breakAtSpace ifTrue: [^ spaceX]. ^ destX. ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'! columnBreak "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. spaceX _ destX. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. ^true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'! cr "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. spaceX _ destX. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. ^true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 2/10/2004 23:03'! endOfRun "Answer true if scanning has reached the end of the paragraph. Otherwise step conditions (mostly install potential new font) and answer false." | runLength | lastIndex = text size ifTrue: [line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. spaceX _ destX. line paddingWidth: rightMargin - destX. presentationLine paddingWidth: rightMargin - destX. ^true] ifFalse: [ "(text at: lastIndex) charCode = 32 ifTrue: [destX _ destX + spaceWidth]." runLength _ (text runLengthFor: (lastIndex _ lastIndex + 1)). runStopIndex _ lastIndex + (runLength - 1). self setStopConditions. ^false] ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 1/3/2003 11:56'! placeEmbeddedObject: anchoredMorph | descent | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit" "But if it's the first character then leave it here" lastIndex < line first ifFalse:[ line stop: lastIndex-1. ^ false]]. descent _ lineHeight - baseline. lineHeight _ lineHeight max: anchoredMorph height. baseline _ lineHeight - descent. line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. ^ true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 21:47'! setFont super setFont. breakAtSpace _ false. wantsColumnBreaks == true ifTrue: [ stopConditions _ stopConditions copy. stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. ]. ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'! setStopConditions "Set the font and the stop conditions for the current run." self setFont! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'! tab "Advance destination x according to tab settings in the paragraph's textStyle. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin. destX > rightMargin ifTrue: [^self crossedX]. lastIndex _ lastIndex + 1. ^false ! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'yo 3/16/2005 19:00'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | "Set up margins" leftMargin _ lineRectangle left. leftSide ifTrue: [leftMargin _ leftMargin + (firstLine ifTrue: [textStyle firstIndent] ifFalse: [textStyle restIndent])]. destX _ spaceX _ leftMargin. firstDestX _ destX. rightMargin _ lineRectangle right. rightSide ifTrue: [rightMargin _ rightMargin - textStyle rightIndent]. lastIndex _ startIndex. "scanning sets last index" destY _ lineRectangle top. lineHeight _ baseline _ 0. "Will be increased by setFont" self setStopConditions. "also sets font" runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. presentationLine _ (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. numOfComposition _ 0. spaceCount _ 0. self handleIndentation. leftMargin _ destX. line leftMargin: leftMargin. presentationLine leftMargin: leftMargin. presentation _ TextStream on: (Text fromString: (MultiString new: text size)). done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading. ^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'yo 1/6/2005 22:58'! composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | destX _ spaceX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex. destY _ 0. rightMargin _ aParagraph rightMarginForComposition. leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose']. lastIndex _ startIndex. "scanning sets last index" lineHeight _ textStyle lineGrid. "may be increased by setFont:..." baseline _ textStyle baseline. baselineY _ destY + baseline. self setStopConditions. "also sets font" self handleIndentation. runLength _ text runLengthFor: startIndex. runStopIndex _ (lastIndex _ startIndex) + (runLength - 1). line _ TextLineInterval start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0. presentationLine _ TextLineInterval start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0. numOfComposition _ 0. presentation _ TextStream on: (Text fromString: (MultiString new: text size)). spaceCount _ 0. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading. ^line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'yo 1/3/2003 11:54'! crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition." (breakAtSpace) ifTrue: [ spaceCount >= 1 ifTrue: ["The common case. First back off to the space at which we wrap." line stop: breakableIndex. presentationLine stop: breakableIndex - numOfComposition. lineHeight _ lineHeightAtBreak. baseline _ baselineAtBreak. spaceCount _ spaceCount - 1. breakableIndex _ breakableIndex - 1. "Check to see if any spaces preceding the one at which we wrap. Double space after punctuation, most likely." [(spaceCount > 1 and: [(text at: breakableIndex) = Space])] whileTrue: [spaceCount _ spaceCount - 1. "Account for backing over a run which might change width of space." font _ text fontAt: breakableIndex withStyle: textStyle. breakableIndex _ breakableIndex - 1. spaceX _ spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. presentationLine internalSpaces: spaceCount. line internalSpaces: spaceCount] ifFalse: ["Neither internal nor trailing spaces -- almost never happens." lastIndex _ lastIndex - 1. [destX <= rightMargin] whileFalse: [destX _ destX - (font widthOf: (text at: lastIndex)). lastIndex _ lastIndex - 1]. spaceX _ destX. line paddingWidth: rightMargin - destX. presentationLine paddingWidth: rightMargin - destX. presentationLine stop: (lastIndex max: line first). line stop: (lastIndex max: line first)]. ^true ]. (breakableIndex isNil or: [breakableIndex < line first]) ifTrue: [ "Any breakable point in this line. Just wrap last character." breakableIndex _ lastIndex - 1. lineHeightAtBreak _ lineHeight. baselineAtBreak _ baseline. ]. "It wasn't a space, but anyway this is where we break the line." line stop: breakableIndex. presentationLine stop: breakableIndex. lineHeight _ lineHeightAtBreak. baseline _ baselineAtBreak. ^ true. ! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'tak 12/22/2004 00:59'! setActualFont: aFont "Keep track of max height and ascent for auto lineheight" | descent | super setActualFont: aFont. "' ', lastIndex printString, ' ' displayAt: (lastIndex * 15)@0." lineHeight == nil ifTrue: [descent _ font descent. baseline _ font ascent. lineHeight _ baseline + descent] ifFalse: [descent _ lineHeight - baseline max: font descent. baseline _ baseline max: font ascent. lineHeight _ lineHeight max: baseline + descent]! ! !MultiCompositionScanner methodsFor: 'intialize-release' stamp: 'yo 12/18/2002 13:57'! forParagraph: aParagraph "Initialize the receiver for scanning the given paragraph." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 1/23/2003 14:40'! presentationText: t text _ t. ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! setDestForm: df bitBlt setDestForm: df.! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 1/6/2005 23:06'! setFont foregroundColor _ paragraphColor. super setFont. "Sets font and emphasis bits, and maybe foregroundColor" font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent. text ifNotNil:[ baselineY _ lineY + line baseline. destY _ baselineY - font ascent]. ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! setPort: aBitBlt "Install the BitBlt to use" bitBlt _ aBitBlt. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt sourceForm: nil. "Make sure font installation won't be confused" ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode text _ t. textStyle _ ts. foregroundColor _ paragraphColor _ foreColor. (backgroundColor _ backColor) isTransparent ifFalse: [fillBlt _ blt. fillBlt fillColor: backgroundColor]. ignoreColorChanges _ shadowMode! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! textColor: textColor ignoreColorChanges ifTrue: [^ self]. foregroundColor _ textColor! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." lastIndex_ lastIndex + 1. ^false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! crossedX "This condition will sometimes be reached 'legally' during display, when, for instance the space that caused the line to wrap actually extends over the right boundary. This character is allowed to display, even though it is technically outside or straddling the clipping ectangle since it is in the normal case not visible and is in any case appropriately clipped by the scanner." ^ true ! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! endOfRun "The end of a run in the display case either means that there is actually a change in the style (run code) to be associated with the string or the end of this line has been reached." | runLength | lastIndex = line last ifTrue: [^true]. runX _ destX. runLength _ text runLengthFor: (lastIndex _ lastIndex + 1). runStopIndex _ lastIndex + (runLength - 1) min: line last. self setStopConditions. ^ false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." spaceCount _ spaceCount + 1. destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount). lastIndex _ lastIndex + 1. ^ false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! plainTab | oldX | oldX _ destX. super plainTab. fillBlt == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). " alignment = Justified ifTrue: [ stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace] "! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! tab self plainTab. lastIndex _ lastIndex + 1. ^ false! ! !MultiDisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 1/7/2005 12:15'! displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle "The central display routine. The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated)." | runLength done stopCondition leftInRun startIndex string lastPos | "leftInRun is the # of characters left to scan in the current run; when 0, it is time to call 'self setStopConditions'" morphicOffset _ 0@0. leftInRun _ 0. self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. ignoreColorChanges _ false. paragraph _ aParagraph. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ bitBlt copy. "Blt to fill spaces, tabs, margins" fillBlt sourceForm: nil; sourceOrigin: 0@0. fillBlt fillColor: aParagraph backgroundColor]. rightMargin _ aParagraph rightMarginForDisplay. lineY _ aParagraph topAtLineIndex: linesInterval first. bitBlt destForm deferUpdatesIn: visibleRectangle while: [ linesInterval do: [:lineIndex | leftMargin _ aParagraph leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment]). destX _ (runX _ leftMargin). line _ aParagraph lines at: lineIndex. lineHeight _ line lineHeight. fillBlt == nil ifFalse: [fillBlt destX: visibleRectangle left destY: lineY width: visibleRectangle width height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions. "also sets the font" leftInRun _ text runLengthFor: line first]. baselineY _ lineY + line baseline. destY _ baselineY - font ascent. "Should have happened in setFont" runLength _ leftInRun. runStopIndex _ lastIndex + (runLength - 1) min: line last. leftInRun _ leftInRun - (runStopIndex - lastIndex + 1). spaceCount _ 0. done _ false. string _ text string. self handleIndentation. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition]. fillBlt == nil ifFalse: [fillBlt destX: destX destY: lineY width: visibleRectangle right-destX height: lineHeight; copyBits]. lineY _ lineY + lineHeight]]! ! !MultiDisplayScanner methodsFor: 'MVC-compatibility' stamp: 'yo 3/14/2005 06:48'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle super initializeFromParagraph: aParagraph clippedBy: clippingRectangle. bitBlt _ BitBlt asGrafPort toForm: aParagraph destinationForm. bitBlt sourceX: 0; width: 0. "Init BitBlt so that the first call to a primitive will not fail" bitBlt combinationRule: Form paint. bitBlt colorMap: (Bitmap with: 0 "Assumes 1-bit deep fonts" with: (bitBlt destForm pixelValueFor: aParagraph foregroundColor)). bitBlt clipRect: clippingRectangle. ! ! !MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:52'! isBreakableAt: index in: sourceString in: encodingClass ^ false. ! ! !MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 8/6/2003 05:57'! scanMultiCharactersCombiningFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | encoding f nextDestX maxAscii startEncoding char charValue | lastIndex _ startIndex. lastIndex > stopIndex ifTrue: [lastIndex _ stopIndex. ^ stops at: EndOfRun]. startEncoding _ (sourceString at: startIndex) leadingChar. font ifNil: [font _ (TextConstants at: #DefaultMultiStyle) fontArray at: 1]. ((font isMemberOf: StrikeFontSet) or: [font isKindOf: TTCFontSet]) ifTrue: [ [f _ font fontArray at: startEncoding + 1] on: Exception do: [:ex | f _ font fontArray at: 1]. f ifNil: [ f _ font fontArray at: 1]. maxAscii _ f maxAscii. spaceWidth _ f widthOf: Space. ] ifFalse: [ maxAscii _ font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ encoding _ (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex _ lastIndex - 1. ^ stops at: EndOfRun]. char _ (sourceString at: lastIndex). charValue _ char charCode. charValue > maxAscii ifTrue: [charValue _ maxAscii]. (encoding = 0 and: [(stopConditions at: charValue + 1) ~~ nil]) ifTrue: [ ^ stops at: charValue + 1 ]. nextDestX _ destX + (self widthOf: char inFont: font). nextDestX > rightX ifTrue: [^ stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1. ]. lastIndex _ stopIndex. ^ stops at: EndOfRun! ! !MultiDisplayScanner methodsFor: 'scanning' stamp: 'yo 1/7/2005 12:15'! displayLine: textLine offset: offset leftInRun: leftInRun "The call on the primitive (scanCharactersFrom:to:in:rightX:) will be interrupted according to an array of stop conditions passed to the scanner at which time the code to handle the stop condition is run and the call on the primitive continued until a stop condition returns true (which means the line has terminated). leftInRun is the # of characters left to scan in the current run; when 0, it is time to call setStopConditions." | done stopCondition nowLeftInRun startIndex string lastPos | line _ textLine. morphicOffset _ offset. lineY _ line top + offset y. lineHeight _ line lineHeight. rightMargin _ line rightMargin + offset x. lastIndex _ line first. leftInRun <= 0 ifTrue: [self setStopConditions]. leftMargin _ (line leftMarginForAlignment: alignment) + offset x. destX _ runX _ leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex _ line first. leftInRun <= 0 ifTrue: [nowLeftInRun _ text runLengthFor: lastIndex] ifFalse: [nowLeftInRun _ leftInRun]. baselineY _ lineY + line baseline. destY _ baselineY - font ascent. runStopIndex _ lastIndex + (nowLeftInRun - 1) min: line last. spaceCount _ 0. done _ false. string _ text string. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern baselineY: baselineY]. "see setStopConditions for stopping conditions for displaying." done _ self perform: stopCondition. "lastIndex > runStopIndex ifTrue: [done _ true]." ]. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !MultiDisplayScanner methodsFor: 'scanning' stamp: 'yo 1/6/2005 22:56'! placeEmbeddedObject: anchoredMorph anchoredMorph relativeTextAnchorPosition ifNotNil:[ anchoredMorph position: anchoredMorph relativeTextAnchorPosition + (anchoredMorph owner textBounds origin x @ 0) - (0@morphicOffset y) + (0@lineY). ^true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [ anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset ] ifFalse: [ destY _ lineY. baselineY _ lineY + anchoredMorph height.. runX _ destX. anchoredMorph displayOn: bitBlt destForm at: destX - anchoredMorph width @ destY clippingBox: bitBlt clipRect ]. ^ true! ! !MultiDisplayScanner class methodsFor: 'queries' stamp: 'yo 12/18/2002 13:58'! defaultFont ^ TextStyle defaultFont! ! !MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 16:09'! displayOn: aCanvas using: displayScanner at: somePosition "Send all visible lines to the displayScanner for display" | visibleRectangle offset leftInRun line | visibleRectangle _ aCanvas clipRect. offset _ somePosition - positionWhenComposed. leftInRun _ 0. (self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [:i | line _ lines at: i. self displaySelectionInLine: line on: aCanvas. line first <= line last ifTrue: [leftInRun _ displayScanner displayLine: line offset: offset leftInRun: leftInRun]]. ! ! !MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 22:33'! displayOnTest: aCanvas using: displayScanner at: somePosition "Send all visible lines to the displayScanner for display" | visibleRectangle offset leftInRun line | (presentationText isNil or: [presentationLines isNil]) ifTrue: [ ^ self displayOn: aCanvas using: displayScanner at: somePosition. ]. visibleRectangle _ aCanvas clipRect. offset _ somePosition - positionWhenComposed. leftInRun _ 0. (self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [:i | line _ presentationLines at: i. self displaySelectionInLine: line on: aCanvas. line first <= line last ifTrue: [leftInRun _ displayScanner displayLine: line offset: offset leftInRun: leftInRun]]. ! ! !MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'! multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult composer presentationInfo | composer _ MultiTextComposer new. presentationLines _ nil. presentationText _ nil. newResult _ composer multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines _ newResult first asArray. maxRightX _ newResult second. presentationInfo _ composer getPresentationInfo. presentationLines _ presentationInfo first asArray. presentationText _ presentationInfo second. "maxRightX printString displayAt: 0@0." ^maxRightX ! ! !MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'! presentationLines ^ presentationLines. ! ! !MultiNewParagraph methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 17:31'! presentationText ^ presentationText. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:40'! at: index ^ MultiCharacter value: (self basicAt: index). ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:42'! at: index put: aCharacter aCharacter isCharacter ifFalse: [ self error: 'MultiStrings only store (descendents of) Characters'. ]. self basicAt: index put: aCharacter asciiValue. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 10/31/2002 22:29'! byteAt: index | d r | d _ (index + 3) // 4. r _ (index - 1) \\ 4 + 1. ^ (self wordAt: d) digitAt: ((4 - r) + 1). ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 11/3/2002 13:19'! byteAt: index put: aByte | d r w | d _ (index + 3) // 4. r _ (index - 1) \\ 4 + 1. w _ (self wordAt: d) bitAnd: ((16rFF<<((4 - r)*8)) bitInvert32). w _ w + (aByte<<((4 - r)*8)). self basicAt: d put: w. ^ aByte. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/27/2002 14:22'! byteSize ^ self size * 4. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 13:46'! findAnySubStr: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that begins a substring matching one of the delimiters. delimiters is an Array of Strings (Characters are permitted also). If the receiver does not contain any of the delimiters, answer size + 1." | min ind | min _ self size + 1. delimiters do: [:delim | "May be a char, a string of length 1, or a substring" delim isCharacter ifTrue: [ind _ self indexOfSubCollection: (MultiString with: delim) startingAt: start ifAbsent: [min]] ifFalse: [ind _ self indexOfSubCollection: (MultiString from: delim) startingAt: start ifAbsent: [min]]. min _ min min: ind]. ^ min. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 11/4/2002 12:05'! findString: key startingAt: start caseSensitive: caseSensitive "Answer the index in this String at which the substring key first occurs, at or beyond start. The match can be case-sensitive or not. If no match is found, zero will be returned." ^ caseSensitive ifTrue: [ self findMultiSubstring: key asMultiString in: self startingAt: start matchTable: nil. ] ifFalse: [ self findMultiSubstring: key asLowercase asMultiString in: self asLowercase startingAt: start matchTable: nil. ]. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:20'! findTokens: delimiters "Answer the collection of tokens that result from parsing self. Return strings between the delimiters. Any character in the Collection delimiters marks a border. Several delimiters in a row are considered as just one separation. Also, allow delimiters to be a single character." | tokens keyStart keyStop separators | tokens _ OrderedCollection new. separators _ delimiters isCharacter ifTrue: [Array with: delimiters] ifFalse: [delimiters]. keyStop _ 1. [keyStop <= self size] whileTrue: [keyStart _ self skipDelimiters: separators startingAt: keyStop. keyStop _ self findDelimiters: separators startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^tokens! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:21'! indexOf: aCharacter ^ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self startingAt: 1 ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:22'! indexOf: aCharacter startingAt: start ^ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self startingAt: start. ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:23'! indexOf: aCharacter startingAt: start ifAbsent: aBlock | ans | ans _ MultiString indexOfAscii: aCharacter asciiValue inMultiString: self startingAt: start. ans = 0 ifTrue: [^ aBlock value] ifFalse: [^ ans] ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 8/28/2002 14:24'! indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock "returns the index of the first character in the given set, starting from start" | ans | ans _ MultiString findFirstInMultiString: self inSet: aCharacterSet byteArrayMap startingAt: start. ans = 0 ifTrue: [^ aBlock value] ifFalse: [^ ans] ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 10/31/2002 22:32'! wordAt: index ^ (self basicAt: index). ! ! !MultiString methodsFor: 'accessing' stamp: 'yo 11/3/2002 13:20'! wordAt: index put: anInteger self basicAt: index put: anInteger. ! ! !MultiString methodsFor: 'encoding' stamp: 'yo 10/23/2002 23:32'! getInteger32: location | integer | integer := ((self basicAt: location) bitShift: 24) + ((self basicAt: location+1) bitShift: 16) + ((self basicAt: location+2) bitShift: 8) + (self basicAt: location+3). integer > 1073741824 ifTrue: [^ 1073741824 - integer ]. ^ integer. ! ! !MultiString methodsFor: 'encoding' stamp: 'yo 10/23/2002 23:32'! putInteger32: anInteger at: location | integer | integer _ anInteger. integer < 0 ifTrue: [integer := 1073741824 - integer. ]. self basicAt: location+3 put: (integer \\ 256). self basicAt: location+2 put: (integer bitShift: -8) \\ 256. self basicAt: location+1 put: (integer bitShift: -16) \\ 256. self basicAt: location put: (integer bitShift: -24) \\ 256. ! ! !MultiString methodsFor: 'encoding' stamp: 'yo 7/29/2003 22:45'! writeLeadingCharRunsOn: stream | runLength runValues runStart leadingChar | self isEmpty ifTrue: [^ self]. runLength _ OrderedCollection new. runValues _ OrderedCollection new. runStart _ 1. leadingChar _ (self at: runStart) leadingChar. 2 to: self size do: [:index | (self at: index) leadingChar = leadingChar ifFalse: [ runValues add: leadingChar. runLength add: (index - runStart). leadingChar _ (self at: index) leadingChar. runStart _ index. ]. ]. runValues add: (self last) leadingChar. runLength add: self size + 1 - runStart. stream nextPut: $(. runLength do: [:rr | rr printOn: stream. stream space]. stream skip: -1; nextPut: $). runValues do: [:vv | vv printOn: stream. stream nextPut: $,]. stream skip: -1. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:17'! asByteArray "Convert to a ByteArray with the ascii values of the string." | b | b _ ByteArray new: self size * 4. 1 to: self size * 4 do: [:i | b at: i put: (self byteAt: i). ]. ^ b. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 2/24/2005 18:34'! asFileName "Answer a String made up from the receiver that is an acceptable file name." | string checkedString | string _ FileDirectory checkName: self fixErrors: true. checkedString _ (FilePath pathName: string) asVmPathName. ^ (FilePath pathName: checkedString isEncoded: true) asSqueakPathName. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:46'! asFourCode | result | self size = 1 ifFalse: [^self error: 'must be exactly four octets']. result _ self basicAt: 1. (result bitAnd: 16r80000000) = 0 ifFalse: [self error: 'cannot resolve fourcode']. (result bitAnd: 16r40000000) = 0 ifFalse: [^result - 16r80000000]. ^ result ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/26/2002 23:08'! asHtml self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/30/2002 16:44'! asMultiString ^ self! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/30/2002 14:09'! asMultiSymbol ^ self asSymbol. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 15:18'! asOctetString | n | self isOctetString ifFalse: [ self error: 'I have non-single byte character(s)'. ]. n _ String new: self size. 1 to: self size do: [:i | n basicAt: i put: (self basicAt: i). ]. ^ n. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/28/2002 14:47'! asPacked self inject: 0 into: [:pack :next | pack _ pack * 16r100000000 + next asInteger]. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:44'! asUnHtml self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:45'! capitalized self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'converting' stamp: 'H.Hachisuka 12/10/2004 22:34'! convertFromSuperSwikiServerString ^self.! ! !MultiString methodsFor: 'converting' stamp: 'H.Hachisuka 12/10/2004 22:34'! convertToSuperSwikiServerString ^self convertToWithConverter: (TextConverter newForEncoding: 'shift_jis').! ! !MultiString methodsFor: 'converting' stamp: 'mir 7/20/2004 15:49'! convertToSystemString | readStream writeStream converter | readStream _ self readStream. writeStream _ String new writeStream. converter _ LanguageEnvironment defaultSystemConverter. converter ifNil: [^ self]. [readStream atEnd] whileFalse: [ converter nextPut: readStream next toStream: writeStream ]. converter emitSequenceToResetStateIfNeededOn: writeStream. ^ writeStream contents. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 3/14/2005 11:41'! copyFrom: start to: stop | n | n _ super copyFrom: start to: stop. n isOctetString ifTrue: [^ n asOctetString]. ^ n. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 10:47'! encodeForHTTP self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'converting' stamp: 'mmo 12/22/2003 23:47'! substrings "Answer an array of the substrings that compose the receiver." ^self findBetweenSubStrs: (Character separators). ! ! !MultiString methodsFor: 'converting' stamp: 'yo 10/31/2002 22:30'! translateFrom: start to: stop table: table "translate the characters in the string by the given table, in place" self flag: #whatToDoWithThis. super translateFrom: start to: stop table: table. ! ! !MultiString methodsFor: 'converting' stamp: 'yo 8/27/2002 14:04'! unzipped self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:22'! < aString ^ (self multiStringCompare: self with: aString asMultiString collated: nil) = 1. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:35'! <= aString ^ (self multiStringCompare: self with: aString collated: nil) <= 2. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:36'! = aString aString isString ifFalse: [^ false]. ^ (self multiStringCompare: self with: (MultiString from: aString) collated: nil) = 2. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:37'! > aString ^ (self multiStringCompare: self with: aString collated: nil) = 3. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:37'! >= aString ^ (self multiStringCompare: self with: aString collated: nil) >= 2. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:38'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string." self size < prefix size ifTrue: [^ false]. ^ (self findMultiSubstring: (MultiString from: prefix) in: self startingAt: 1 matchTable: nil) = 1 ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 11/12/2002 10:59'! caseInsensitiveLessOrEqual: aString ^ (self multiStringCompare: self with: aString asMultiString collated: CaseInsensitiveOrder) <= 2. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:39'! caseSensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case sensitive." ^ (self multiStringCompare: self with: aString collated: nil) <= 2 ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 10/31/2002 22:31'! compare: aString "Answer a comparison code telling how the receiver sorts relative to aString: 1 - before 2 - equal 3 - after. " ^ self multiStringCompare: self with: aString collated: nil ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 8/28/2002 14:41'! crc16 "Compute a 16 bit cyclic redundancy check." | crc | crc := 0. 1 to: self size * 4 do: [:i | crc := (crc bitShift: -8) bitXor: ( #( 16r0000 16rC0C1 16rC181 16r0140 16rC301 16r03C0 16r0280 16rC241 16rC601 16r06C0 16r0780 16rC741 16r0500 16rC5C1 16rC481 16r0440 16rCC01 16r0CC0 16r0D80 16rCD41 16r0F00 16rCFC1 16rCE81 16r0E40 16r0A00 16rCAC1 16rCB81 16r0B40 16rC901 16r09C0 16r0880 16rC841 16rD801 16r18C0 16r1980 16rD941 16r1B00 16rDBC1 16rDA81 16r1A40 16r1E00 16rDEC1 16rDF81 16r1F40 16rDD01 16r1DC0 16r1C80 16rDC41 16r1400 16rD4C1 16rD581 16r1540 16rD701 16r17C0 16r1680 16rD641 16rD201 16r12C0 16r1380 16rD341 16r1100 16rD1C1 16rD081 16r1040 16rF001 16r30C0 16r3180 16rF141 16r3300 16rF3C1 16rF281 16r3240 16r3600 16rF6C1 16rF781 16r3740 16rF501 16r35C0 16r3480 16rF441 16r3C00 16rFCC1 16rFD81 16r3D40 16rFF01 16r3FC0 16r3E80 16rFE41 16rFA01 16r3AC0 16r3B80 16rFB41 16r3900 16rF9C1 16rF881 16r3840 16r2800 16rE8C1 16rE981 16r2940 16rEB01 16r2BC0 16r2A80 16rEA41 16rEE01 16r2EC0 16r2F80 16rEF41 16r2D00 16rEDC1 16rEC81 16r2C40 16rE401 16r24C0 16r2580 16rE541 16r2700 16rE7C1 16rE681 16r2640 16r2200 16rE2C1 16rE381 16r2340 16rE101 16r21C0 16r2080 16rE041 16rA001 16r60C0 16r6180 16rA141 16r6300 16rA3C1 16rA281 16r6240 16r6600 16rA6C1 16rA781 16r6740 16rA501 16r65C0 16r6480 16rA441 16r6C00 16rACC1 16rAD81 16r6D40 16rAF01 16r6FC0 16r6E80 16rAE41 16rAA01 16r6AC0 16r6B80 16rAB41 16r6900 16rA9C1 16rA881 16r6840 16r7800 16rB8C1 16rB981 16r7940 16rBB01 16r7BC0 16r7A80 16rBA41 16rBE01 16r7EC0 16r7F80 16rBF41 16r7D00 16rBDC1 16rBC81 16r7C40 16rB401 16r74C0 16r7580 16rB541 16r7700 16rB7C1 16rB681 16r7640 16r7200 16rB2C1 16rB381 16r7340 16rB101 16r71C0 16r7080 16rB041 16r5000 16r90C1 16r9181 16r5140 16r9301 16r53C0 16r5280 16r9241 16r9601 16r56C0 16r5780 16r9741 16r5500 16r95C1 16r9481 16r5440 16r9C01 16r5CC0 16r5D80 16r9D41 16r5F00 16r9FC1 16r9E81 16r5E40 16r5A00 16r9AC1 16r9B81 16r5B40 16r9901 16r59C0 16r5880 16r9841 16r8801 16r48C0 16r4980 16r8941 16r4B00 16r8BC1 16r8A81 16r4A40 16r4E00 16r8EC1 16r8F81 16r4F40 16r8D01 16r4DC0 16r4C80 16r8C41 16r4400 16r84C1 16r8581 16r4540 16r8701 16r47C0 16r4680 16r8641 16r8201 16r42C0 16r4380 16r8341 16r4100 16r81C1 16r8081 16r4040) at: ((crc bitXor: (self byteAt: i)) bitAnd: 16rFF) + 1) ]. ^crc. ! ! !MultiString methodsFor: 'comparing' stamp: 'yo 11/5/2002 15:14'! sameAs: aString "Answer whether the receiver sorts equal to aString. The collation sequence is ascii with case differences ignored." ^ (self multiStringCompare: self with: aString asMultiString collated: CaseInsensitiveOrder) = 2. ! ! !MultiString methodsFor: 'system primitives' stamp: 'yo 8/28/2002 14:35'! compare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." ^ self multiStringCompare: string1 with: string2 collated: order. ! ! !MultiString methodsFor: 'system primitives' stamp: 'yo 12/27/2002 04:34'! findMultiSubstring: key in: body startingAt: start matchTable: matchTable "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned. The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter." | index c1 c2 | self var: #key declareC: 'unsigned int *key'. self var: #body declareC: 'unsigned int *body'. self var: #matchTable declareC: 'unsigned char *matchTable'. self var: #c1 declareC: 'unsigned int c1'. self var: #c2 declareC: 'unsigned int c2'. matchTable == nil ifTrue: [ key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index _ 1. [(body at: startIndex+index-1) = (key at: index)] whileTrue: [index = key size ifTrue: [^ startIndex]. index _ index+1]]. ^ 0 ]. key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index _ 1. [c1 _ body at: startIndex+index-1. c2 _ key at: index. ((c1 leadingChar = 0) ifTrue: [(matchTable at: c1 asciiValue + 1)] ifFalse: [c1 asciiValue + 1]) = ((c2 leadingChar = 0) ifTrue: [(matchTable at: c2 asciiValue + 1)] ifFalse: [c2 asciiValue + 1])] whileTrue: [index = key size ifTrue: [^ startIndex]. index _ index+1]]. ^ 0 ! ! !MultiString methodsFor: 'system primitives' stamp: 'yo 11/4/2002 12:06'! findSubstring: key in: body startingAt: start matchTable: matchTable ^ self findMultiSubstring: key asMultiString in: body asMultiString startingAt: start matchTable: matchTable. ! ! !MultiString methodsFor: 'system primitives' stamp: 'yo 11/5/2002 15:14'! multiStringCompare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." | len1 len2 c1 c2 | self var: #string1 declareC: 'unsigned int *string1'. self var: #string2 declareC: 'unsigned int *string2'. self var: #order declareC: 'unsigned char *order'. order == nil ifTrue: [ len1 _ string1 size. len2 _ string2 size. 1 to: (len1 min: len2) do: [:i | c1 _ string1 basicAt: i. c2 _ string2 basicAt: i. c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]]. len1 = len2 ifTrue: [^ 2]. len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. ]. len1 _ string1 size. len2 _ string2 size. 1 to: (len1 min: len2) do: [:i | c1 _ string1 basicAt: i. c2 _ string2 basicAt: i. c1 < 256 ifTrue: [c1 _ order at: c1 + 1]. c2 < 256 ifTrue: [c2 _ order at: c2 + 1]. c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]]. len1 = len2 ifTrue: [^ 2]. len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. ! ! !MultiString methodsFor: 'testing' stamp: 'yo 7/29/2003 14:10'! includesUnifiedCharacter ^ self isUnicodeStringWithCJK ! ! !MultiString methodsFor: 'testing' stamp: 'yo 8/28/2002 22:43'! isOctetString 1 to: self size do: [:pos | (self basicAt: pos) >= 256 ifTrue: [^ false]. ]. ^ true. ! ! !MultiString methodsFor: 'testing' stamp: 'yo 12/30/2002 15:57'! isUnicodeString self do: [:c | c isUnicode ifTrue: [ ^ true ]. ]. ^ false. ! ! !MultiString methodsFor: 'testing' stamp: 'yo 1/15/2004 14:56'! isUnicodeStringWithCJK self do: [:c | (c isUnicode and: [Unicode isUnifiedKanji: c charCode]) ifTrue: [ ^ true ]. ]. ^ false. ! ! !MultiString methodsFor: 'private' stamp: 'yo 3/17/2004 15:47'! mutateJISX0208StringToUnicode | c | 1 to: self size do: [:i | c _ self at: i. (c leadingChar = JISX0208 leadingChar or: [ c leadingChar = (JISX0208 leadingChar bitShift: 2)]) ifTrue: [ self basicAt: i put: (MultiCharacter leadingChar: JapaneseEnvironment leadingChar code: (c asUnicode)) asciiValue. ] ]. ! ! !MultiString methodsFor: 'private' stamp: 'yo 8/28/2002 16:56'! replaceFrom: start to: stop with: replacement startingAt: repStart <primitive: 105> replacement class == String ifTrue: [ ^ self replaceFrom: start to: stop with: (replacement asMultiString) startingAt: repStart. ]. ^ super replaceFrom: start to: stop with: replacement startingAt: repStart. ! ! !MultiString methodsFor: 'internet' stamp: 'yo 8/26/2002 22:39'! decodeQuotedPrintable "Assume receiver is in MIME 'quoted-printable' encoding, and decode it." self flag: #toBeImplemented. ! ! !MultiString methodsFor: 'internet' stamp: 'yo 8/26/2002 22:47'! unescapePercents self flag: #toBeImplemented. ! ! !MultiString commentStamp: 'yo 10/19/2004 22:34' prior: 0! This class represents the array of 32 bit wide characters. ! !MultiString class methodsFor: 'enumeration' stamp: 'yo 8/27/2003 07:01'! allMethodsWithEncodingTag: encodingTag "Answer a SortedCollection of all the methods that implement the message aSelector." | list adder num i | list _ Set new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel ) ]. num _ CompiledMethod allInstances size. i _ 0. 'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar | SystemNavigation new allBehaviorsDo: [ :class | class selectors do: [:s | bar value: (i _ i + 1). (self string: (class sourceCodeAt: s) asString hasEncoding: encodingTag) ifTrue: [ adder value: class value: s. ] ] ] ]. ^ list. ! ! !MultiString class methodsFor: 'enumeration' stamp: 'yo 8/12/2003 17:14'! allMultiStringMethods "Answer a SortedCollection of all the methods that implement the message aSelector." | list adder num i | list _ Set new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel ) ]. num _ CompiledMethod allInstances size. i _ 0. 'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar | SystemNavigation new allBehaviorsDo: [ :class | class selectors do: [:s | bar value: (i _ i + 1). ((class sourceCodeAt: s) asString isOctetString) ifFalse: [ adder value: class value: s. ] ] ] ]. ^ list. ! ! !MultiString class methodsFor: 'enumeration' stamp: 'yo 8/27/2003 07:00'! allNonAsciiMethods "Answer a SortedCollection of all the methods that implement the message aSelector." | list adder num i | list _ Set new. adder _ [ :mrClass :mrSel | list add: ( MethodReference new setStandardClass: mrClass methodSymbol: mrSel ) ]. num _ CompiledMethod allInstances size. i _ 0. 'processing...' displayProgressAt: Sensor cursorPoint from: 0 to: num during: [:bar | SystemNavigation new allBehaviorsDo: [ :class | class selectors do: [:s | bar value: (i _ i + 1). ((class sourceCodeAt: s) asString isAsciiString) ifFalse: [ adder value: class value: s. ] ] ] ]. ^ list. ! ! !MultiString class methodsFor: 'enumeration' stamp: 'yo 8/5/2003 14:20'! string: str hasEncoding: encoding str do: [:each | each leadingChar = encoding ifTrue: [^ true]]. ^ false. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:00'! findFirstInMultiString: aString inSet: inclusionMap startingAt: start | i stringSize ascii more | self var: #aString declareC: 'unsigned int *aString'. self var: #inclusionMap declareC: 'char *inclusionMap'. inclusionMap size ~= 256 ifTrue: [^ 0]. stringSize _ aString size. more _ true. i _ start - 1. [more and: [i + 1 <= stringSize]] whileTrue: [ i _ i + 1. ascii _ (aString at: i) asciiValue. more _ ascii < 256 ifTrue: [(inclusionMap at: ascii + 1) = 0] ifFalse: [true]. ]. i + 1 > stringSize ifTrue: [^ 0]. ^ i. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:07'! findFirstInString: aString inSet: inclusionMap startingAt: start ^ self findFirstInMultiString: aString inSet: inclusionMap startingAt: start. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:05'! indexOfAscii: anInteger inMultiString: aString startingAt: start | stringSize | self var: #aCharacter declareC: 'int anInteger'. self var: #aString declareC: 'unsigned int *aString'. stringSize _ aString size. start to: stringSize do: [:pos | (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. ^ 0 ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:06'! indexOfAscii: anInteger inString: aString startingAt: start ^ self indexOfAscii: anInteger inMultiString: aString startingAt: start. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 13:16'! multiStringHash: aString initialHash: speciesHash | stringSize hash low | self var: #aHash declareC: 'int speciesHash'. self var: #aString declareC: 'unsigned int *aString'. stringSize _ aString size. hash _ speciesHash bitAnd: 16rFFFFFFF. 1 to: stringSize do: [:pos | hash _ hash + (aString at: pos) asciiValue. "Begin hashMultiply" low _ hash bitAnd: 16383. hash _ (16r260D * low + ((16r260D * (hash bitShift: -14) + (16r0065 * low) bitAnd: 16383) * 16384)) bitAnd: 16r0FFFFFFF. ]. ^ hash. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 11/7/2002 14:18'! stringHash: aString initialHash: speciesHash aString isOctetString ifTrue: [^ aString asOctetString hash]. ^ self multiStringHash: aString initialHash: speciesHash. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 8/28/2002 15:10'! translate: aString from: start to: stop table: table ^ self translateMultiString: aString from: start to: stop table: table. ! ! !MultiString class methodsFor: 'primitives' stamp: 'yo 11/4/2002 22:58'! translateMultiString: aString from: start to: stop table: table "translate the characters in the string by the given table, in place" | char | self var: #table declareC: 'unsigned char *table'. self var: #aString declareC: 'unsigned int *aString'. start to: stop do: [:i | char _ aString basicAt: i. char < 256 ifTrue: [ aString basicAt: i put: (table at: char+1) asciiValue ]. ]. ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 14:51'! correspondingSymbolClass ^ MultiSymbol ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 16:57'! from: aString | multiString | (aString isMemberOf: self) ifTrue: [^ aString copy]. multiString _ self new: aString size. 1 to: aString size do: [:index | multiString basicAt: index put: (aString basicAt: index)]. ^ multiString ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 10/23/2002 23:33'! fromByteArray: aByteArray | inst | aByteArray size \\ 4 = 0 ifFalse: [^ String fromByteArray: aByteArray ]. inst _ self new: aByteArray size // 4. 4 to: aByteArray size by: 4 do: [:i | inst basicAt: i // 4 put: ((aByteArray at: i - 3) << 24) + ((aByteArray at: i - 2) << 16) + ((aByteArray at: i - 1) << 8) + (aByteArray at: i) ]. ^ inst ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 17:00'! fromISO2022JPString: string | tempFileName stream contents | tempFileName _ Time millisecondClockValue printString , '.txt'. FileDirectory default deleteFileNamed: tempFileName ifAbsent: []. stream _ StandardFileStream fileNamed: tempFileName. [stream nextPutAll: string] ensure: [stream close]. stream _ FileStream fileNamed: tempFileName. contents _ stream contentsOfEntireFile. FileDirectory default deleteFileNamed: tempFileName ifAbsent: []. ^ contents ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:25'! fromPacked: aLong "Convert from a longinteger to a String of length 4." | s val | s _ self new: 1. val _ ((aLong digitAt: 4) << 24) | ((aLong digitAt: 3) << 16) | ((aLong digitAt: 2) << 8) | (aLong digitAt: 1). s basicAt: 1 put: val. ^ s. "MultiString fromPacked: 'TEXT' asPacked" ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:39'! fromString: aString "Answer an instance of me that is a copy of the argument, aString." | inst | (aString isMemberOf: self) ifTrue: [ ^ aString copy. ]. inst _ self new: aString size. 1 to: aString size do: [:pos | inst basicAt: pos put: (aString basicAt: pos). ]. ^ inst. ! ! !MultiString class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 13:30'! value: anInteger ^ self with: (MultiCharacter value: anInteger). ! ! !MultiString class methodsFor: 'plugin generation' stamp: 'yo 8/26/2002 20:42'! ccg: cg prolog: aBlock expr: aString index: anInteger ^cg ccgLoad: aBlock expr: aString asCharPtrFrom: anInteger andThen: (cg ccgValBlock: 'isBytes')! ! !MultiString class methodsFor: 'plugin generation' stamp: 'yo 8/26/2002 20:42'! ccgDeclareCForVar: aSymbolOrString ^'char *', aSymbolOrString! ! !MultiStringTest methodsFor: 'testing - converting' stamp: 'laza 10/1/2004 09:58'! testAsInteger self assert: '1796exportFixes-tkMX' asMultiString asInteger = 1796. self assert: 'donald' asMultiString asInteger isNil. self assert: 'abc234def567' asMultiString asInteger = 234. self assert: '-94' asMultiString asInteger = -94. self assert: 'foo-bar-92' asMultiString asInteger = -92. self assert: '1796exportFixes-tkMX' asMultiString asSignedInteger = 1796. self assert: 'donald' asMultiString asSignedInteger isNil. self assert: 'abc234def567' asMultiString asSignedInteger = 234. self assert: '-94' asMultiString asSignedInteger = -94. self assert: 'foo-bar-92' asMultiString asSignedInteger = -92. self assert: '1796exportFixes-tkMX' asMultiString asUnsignedInteger = 1796. self assert: 'donald' asMultiString asUnsignedInteger isNil. self assert: 'abc234def567' asMultiString asUnsignedInteger = 234. self assert: '-94' asMultiString asUnsignedInteger = 94. self assert: 'foo-bar-92' asMultiString asUnsignedInteger = 92! ! !MultiStringTest commentStamp: '<historical>' prior: 0! This is the unit test for the class String. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !MultiSymbol methodsFor: 'filter streaming' stamp: 'yo 8/30/2002 14:15'! byteEncode:aStream ^ aStream writeSymbol: self. ! ! !MultiSymbol methodsFor: 'copying' stamp: 'yo 8/30/2002 14:15'! clone "Answer with the receiver, because MultiSymbols are unique." ! ! !MultiSymbol methodsFor: 'copying' stamp: 'yo 8/30/2002 14:15'! copy "Answer with the receiver, because MultiSymbols are unique." ! ! !MultiSymbol methodsFor: 'copying' stamp: 'yo 8/30/2002 14:17'! shallowCopy "Answer with the receiver, because MultiSymbols are unique." ! ! !MultiSymbol methodsFor: 'copying' stamp: 'yo 11/3/2002 13:23'! veryDeepCopyWith: deepCopier "Return self. I am immutable in the Morphic world. Do not record me." ! ! !MultiSymbol methodsFor: 'system primitives' stamp: 'yo 8/30/2002 14:16'! flushCache "Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. NOTE: Only one of the two selective flush methods needs to be used. Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." <primitive: 119> ! ! !MultiSymbol methodsFor: 'converting' stamp: 'yo 8/30/2002 14:14'! asExplorerString ^ self printString. ! ! !MultiSymbol methodsFor: 'converting' stamp: 'yo 8/30/2002 14:14'! asMultiSymbol "Refer to the comment in String|asMultiSymbol." ! ! !MultiSymbol methodsFor: 'converting' stamp: 'yo 8/30/2002 14:14'! asString "Refer to the comment in String|asString." | newString | newString _ String new: self size. 1 to: self size do: [:index | newString at: index put: (self at: index)]. ^ newString ! ! !MultiSymbol methodsFor: 'converting' stamp: 'yo 8/30/2002 14:15'! asSymbol "Refer to the comment in String|asMultiSymbol." ! ! !MultiSymbol methodsFor: 'converting' stamp: 'yo 8/30/2002 14:15'! capitalized ^ self asString capitalized asMultiSymbol. ! ! !MultiSymbol methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:15'! at: anInteger put: anObject "You cannot modify the receiver." self errorNoModification ! ! !MultiSymbol methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:17'! precedence "Answer the receiver's precedence, assuming it is a valid Smalltalk message selector or 0 otherwise. The numbers are 1 for unary, 2 for binary and 3 for keyword selectors." self size = 0 ifTrue: [^ 0]. self first isLetter ifFalse: [^ 2]. self last = $: ifTrue: [^ 3]. ^ 1 ! ! !MultiSymbol methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:17'! replaceFrom: start to: stop with: replacement startingAt: repStart self errorNoModification ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:16'! isInfix "Answer whether the receiver is an infix message selector." ^ self precedence == 2 ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:16'! isKeyword "Answer whether the receiver is a message keyword." ^ self precedence == 3 ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:16'! isLiteral "Answer whether the receiver is a valid Smalltalk literal." ^ true ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:16'! isOrientedFill "Needs to be implemented here because symbols can occupy 'color' slots of morphs." ^ false ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:17'! isPvtSelector "Answer whether the receiver is a private message selector, that is, begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash." ^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]. ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 11/3/2002 13:22'! isSymbol ^ true. ! ! !MultiSymbol methodsFor: 'testing' stamp: 'yo 8/30/2002 14:17'! isUnary "Answer whether the receiver is an unary message selector." ^ self precedence == 1. ! ! !MultiSymbol methodsFor: 'comparing' stamp: 'yo 8/30/2002 14:14'! = another "Use == between two symbols..." self == another ifTrue: [^ true]. "Was == " another class == MultiSymbol ifTrue: [^ false]. "Was not == " "Otherwise use string =..." ^ super = another. ! ! !MultiSymbol methodsFor: 'printing' stamp: 'yo 8/30/2002 14:18'! storeOn: aStream aStream nextPut: $#. (Scanner isLiteralMultiSymbol: self) ifTrue: [aStream nextPutAll: self] ifFalse: [super storeOn: aStream]. ! ! !MultiSymbol methodsFor: 'private' stamp: 'yo 8/30/2002 14:16'! errorNoModification self error: 'symbols can not be modified.' ! ! !MultiSymbol methodsFor: 'private' stamp: 'yo 11/3/2002 13:22'! species ^ MultiString ! ! !MultiSymbol methodsFor: 'private' stamp: 'yo 11/3/2002 13:21'! string: aString 1 to: aString size do: [:j | super at: j put: (aString at: j)]. ^ self ! ! !MultiSymbol methodsFor: 'Camp Smalltalk' stamp: 'yo 11/3/2002 13:21'! sunitAsClass ^ SUnitNameResolver classNamed: self. ! ! !MultiSymbol methodsFor: 'objects from disk' stamp: 'tk 12/6/2004 10:36'! fixUponLoad: aProject seg: anImageSegment "We are in an old project that is being loaded from disk. Fix up conventions that have changed." | ms | "Yoshiki did not put MultiSymbols into outPointers in older images!! When all old images are gone, remove this method." ms _ MultiSymbol intern: self asString. self == ms ifFalse: ["For a project from older m17n image, this is necessary." self becomeForward: ms. aProject projectParameters at: #MultiSymbolInWrongPlace put: true]. ^ super fixUponLoad: aProject seg: anImageSegment "me, not the label" ! ! !MultiSymbol commentStamp: 'yo 10/19/2004 22:42' prior: 0! This class represents the symbols whose slots are the MultiCharacters. The protocol is basically the same as the one of Symbol with a few exceptions. Some think the separated symbol tables from the ones of Symbol isn't a great idea. I kind of disagree but would like to see a better solution. ! !MultiSymbol class methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:54'! selectorsContaining: aString "Answer a list of selectors that contain aString within them. Case-insensitive. Does return symbols that begin with a capital letter." | size selectorList ascii | selectorList _ OrderedCollection new. (size _ aString size) = 0 ifTrue: [^ selectorList]. aString size = 1 ifTrue: [ ascii _ aString first asciiValue. ascii < 128 ifTrue: [selectorList add: (OneCharacterMultiSymbols at: ascii+1)] ]. aString first isLetter ifFalse: [ aString size = 2 ifTrue: [MultiSymbol hasInterned: aString ifTrue: [:s | selectorList add: s]]. ^ selectorList ]. selectorList _ selectorList copyFrom: 2 to: selectorList size. self allMultiSymbolTablesDo: [:each | each size >= size ifTrue: [(each findSubstring: aString in: each startingAt: 1 matchTable: CaseInsensitiveOrder) > 0 ifTrue: [selectorList add: each]]]. ^selectorList reject: [:each | "reject non-selectors, but keep ones that begin with an uppercase" each numArgs < 0 and: [each asString withFirstCharacterDownshifted numArgs < 0]]. "MultiSymbol selectorsContaining: 'scon'"! ! !MultiSymbol class methodsFor: 'accessing' stamp: 'yo 8/30/2002 14:55'! thatStarts: leadingCharacters skipping: skipSym "Answer a selector symbol that starts with leadingCharacters. MultiSymbols beginning with a lower-case letter handled directly here. Ignore case after first char. If skipSym is not nil, it is a previous answer; start searching after it. If no symbols are found, answer nil. Used by Alt-q (Command-q) routines" | size firstMatch key | size _ leadingCharacters size. size = 0 ifTrue: [^skipSym ifNil: [#''] ifNotNil: [nil]]. firstMatch _ leadingCharacters at: 1. size > 1 ifTrue: [key _ leadingCharacters copyFrom: 2 to: size]. self allMultiSymbolTablesDo: [:each | each size >= size ifTrue: [ ((each at: 1) == firstMatch and: [key == nil or: [(each findString: key startingAt: 2 caseSensitive: false) = 2]]) ifTrue: [^each] ] ] after: skipSym. ^nil "MultiSymbol thatStarts: 'sf' skipping: nil" "MultiSymbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:" "MultiSymbol thatStarts: 'candidate' skipping: nil" ! ! !MultiSymbol class methodsFor: 'class initialization' stamp: 'yo 8/30/2002 14:55'! allMultiSymbolTablesDo: aBlock NewMultiSymbols do: aBlock. MultiSymbolTable do: aBlock. ! ! !MultiSymbol class methodsFor: 'class initialization' stamp: 'yo 8/30/2002 14:55'! allMultiSymbolTablesDo: aBlock after: aMultiSymbol NewMultiSymbols do: aBlock after: aMultiSymbol. MultiSymbolTable do: aBlock after: aMultiSymbol. ! ! !MultiSymbol class methodsFor: 'class initialization' stamp: 'yo 8/30/2002 14:56'! compactMultiSymbolTable "Reduce the size of the symbol table so that it holds all existing symbols + 25% (changed from 1000 since sets like to have 25% free and the extra space would grow back in a hurry)" | oldSize | Smalltalk garbageCollect. oldSize _ MultiSymbolTable array size. MultiSymbolTable growTo: MultiSymbolTable size * 4 // 3 + 100. ^oldSize printString,' ',(oldSize - MultiSymbolTable array size) printString, ' slot(s) reclaimed' ! ! !MultiSymbol class methodsFor: 'class initialization' stamp: 'nk 7/29/2004 10:23'! compareTiming " MultiSymbol compareTiming " | answer t selectorList implementorLists flattenedList md | answer _ WriteStream on: String new. SmalltalkImage current timeStamp: answer. answer cr; cr. answer nextPutAll: MethodDictionary instanceCount printString,' method dictionaries'; cr; cr. answer nextPutAll: ( MethodDictionary allInstances inject: 0 into: [ :sum :each | sum + each size]) printString, ' method dictionary entries'; cr; cr. md _ MethodDictionary allInstances. t _ [100 timesRepeat: [md do: [ :each | each includesKey: #majorShrink]]] timeToRun. answer nextPutAll: t printString, ' ms to check all method dictionaries for #majorShrink 1000 times'; cr; cr. selectorList _ MultiSymbol selectorsContaining: 'help'. t _ [ 3 timesRepeat: [selectorList collect: [:each | SystemNavigation default allImplementorsOf: each]] ] timeToRun. answer nextPutAll: t printString,' ms to do #allImplementorsOf: for ', selectorList size printString,' selectors like *help* 3 times'; cr; cr. t _ [ 3 timesRepeat: [ selectorList do: [:eachSel | md do: [ :eachMd | eachMd includesKey: eachSel]] ] ] timeToRun. answer nextPutAll: t printString,' ms to do #includesKey: for ', md size printString,' methodDicts for ', selectorList size printString,' selectors like *help* 3 times'; cr; cr. #('help' 'majorShrink') do: [ :substr | answer nextPutAll: (MultiSymbol selectorsContaining: substr) size printString, ' selectors containing "',substr,'"'; cr. t _ [ 3 timesRepeat: [ selectorList _ MultiSymbol selectorsContaining: substr. ]. ] timeToRun. answer nextPutAll: t printString,' ms to find MultiSymbols containing *',substr,'* 3 times'; cr. t _ [ 3 timesRepeat: [ selectorList _ MultiSymbol selectorsContaining: substr. implementorLists _ selectorList collect: [:each | Smalltalk allImplementorsOf: each]. flattenedList _ SortedCollection new. implementorLists do: [:each | flattenedList addAll: each]. ]. ] timeToRun. answer nextPutAll: t printString,' ms to find implementors of *',substr,'* 3 times'; cr; cr. ]. StringHolder new contents: answer contents; openLabel: 'timing'. ! ! !MultiSymbol class methodsFor: 'class initialization' stamp: 'yo 8/30/2002 14:56'! initialize "MultiSymbol initialize" MultiSymbol rehash. OneCharacterMultiSymbols _ nil. OneCharacterMultiSymbols _ (1 to: 256) collect: [ :i | (i - 1) asCharacter asSymbol]. Smalltalk addToShutDownList: self. ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/4/2002 23:16'! intern: aStringOrMultiSymbol aStringOrMultiSymbol isOctetString ifTrue: [^ Symbol intern: aStringOrMultiSymbol]. ^ (self lookup: aStringOrMultiSymbol) ifNil: [NewMultiSymbols add: ((aStringOrMultiSymbol isKindOf: MultiSymbol) ifTrue: [aStringOrMultiSymbol] ifFalse: [(self new: aStringOrMultiSymbol size) string: aStringOrMultiSymbol])] ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 14:57'! internCharacter: aCharacter OneCharacterMultiSymbols ifNil: [^self intern: aCharacter asString]. ^ OneCharacterMultiSymbols at: aCharacter asciiValue + 1 ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/11/2002 23:43'! internLoadedSymbol: aStringOrMultiSymbol aStringOrMultiSymbol isOctetString ifTrue: [^ Symbol intern: aStringOrMultiSymbol]. ^ (self lookupForLoadedSymbol: aStringOrMultiSymbol) ifNil: [NewMultiSymbols add: ((aStringOrMultiSymbol isKindOf: MultiSymbol) ifTrue: [aStringOrMultiSymbol] ifFalse: [(self new: aStringOrMultiSymbol size) string: aStringOrMultiSymbol])] ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 14:57'! lookup: aStringOrMultiSymbol ^(MultiSymbolTable like: aStringOrMultiSymbol) ifNil: [ NewMultiSymbols like: aStringOrMultiSymbol ]. ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 11/11/2002 23:13'! lookupForLoadedSymbol: aStringOrMultiSymbol ^(MultiSymbolTable likeLoadedSymbol: aStringOrMultiSymbol) ifNil: [ NewMultiSymbols likeLoadedSymbol: aStringOrMultiSymbol ]. ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 14:57'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^ (aCollection as: MultiString) asMultiSymbol " MultiSymbol newFrom: {$P. $e. $n} {$P. $e. $n} as: MultiSymbol " ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 14:57'! newFromStream: stream | length multiString | self isPointers | self isWords not ifTrue: [^ super newFromStream: stream]. stream next = 128 ifTrue: [^ self error: 'not implemented']. stream skip: -1. length _ stream nextInt32. multiString _ stream nextWordsInto: (MultiString basicNew: length). ^ multiString asSymbol ! ! !MultiSymbol class methodsFor: 'instance creation' stamp: 'yo 8/30/2002 14:58'! readFrom: strm "MultiSymbol readFromString: '#abc'" strm peek = $# ifFalse: [self error: 'MultiSymbols must be introduced by #']. ^ (Scanner new scan: strm) advance "Just do what the code scanner does" ! ! !MultiSymbol class methodsFor: 'private' stamp: 'yo 8/30/2002 14:58'! hasInterned: aString ifTrue: symBlock "Answer with false if aString hasnt been interned (into a MultiSymbol), otherwise supply the symbol to symBlock and return true." | symbol | ^(symbol _ self lookup: aString) ifNil: [false] ifNotNil: [symBlock value: symbol. true] ! ! !MultiSymbol class methodsFor: 'private' stamp: 'yo 11/11/2002 23:22'! hasInternedALoadedSymbol: aString ifTrue: symBlock "Answer with false if aString hasnt been interned (into a MultiSymbol), otherwise supply the symbol to symBlock and return true." | symbol | ^(symbol _ self lookupForLoadedSymbol: aString) ifNil: [false] ifNotNil: [symBlock value: symbol. true] ! ! !MultiSymbol class methodsFor: 'private' stamp: 'yo 8/30/2002 14:58'! possibleSelectorsFor: misspelled "Answer an ordered collection of possible corrections for the misspelled selector in order of likelyhood" | numArgs candidates lookupString best binary short long first ss | lookupString _ misspelled asLowercase. "correct uppercase selectors to lowercase" numArgs _ lookupString numArgs. (numArgs < 0 or: [lookupString size < 2]) ifTrue: [^ OrderedCollection new: 0]. first _ lookupString first. short _ lookupString size - (lookupString size // 4 max: 3) max: 2. long _ lookupString size + (lookupString size // 4 max: 3). "First assemble candidates for detailed scoring" candidates _ OrderedCollection new. self allMultiSymbolTablesDo: [:s | (((ss _ s size) >= short "not too short" and: [ss <= long "not too long" or: [(s at: 1) = first]]) "well, any length OK if starts w/same letter" and: [s numArgs = numArgs]) "and numArgs is the same" ifTrue: [candidates add: s]]. "Then further prune these by correctAgainst:" best _ lookupString correctAgainst: candidates. ((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [ binary _ misspelled, ':'. "try for missing colon" MultiSymbol hasInterned: binary ifTrue: [:him | best addFirst: him]]. ^ best ! ! !MultiSymbol class methodsFor: 'private' stamp: 'yo 8/30/2002 14:58'! rehash "MultiSymbol rehash" "Rebuild the hash table, reclaiming unreferenced MultiSymbols." MultiSymbolTable _ WeakSet withAll: self allInstances. NewMultiSymbols _ WeakSet new. ! ! !MultiSymbol class methodsFor: 'private' stamp: 'yo 8/30/2002 14:59'! shutDown: aboutToQuit MultiSymbolTable addAll: NewMultiSymbols. NewMultiSymbols _ WeakSet new. ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:08'! access: char at: index | wcache entry | wcache _ self cache. entry _ wcache at: index. wcache replaceFrom: index to: wcache size - 1 with: wcache startingAt: index + 1. wcache at: wcache size put: entry. ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:09'! at: char put: form | wcache | wcache _ self cache. wcache replaceFrom: 1 to: wcache size - 1 with: wcache startingAt: 2. wcache at: wcache size put: (Array with: char asciiValue with: foregroundColor with: form). ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:27'! flushCache cache at: 1 put: ((1 to: 128) collect: [:i | Array with: -1 with: nil with: nil]). ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 21:04'! formOf: char | newForm | self hasCached: char ifTrue: [:form :index | self access: char at: index. ^ form. ]. newForm _ self computeForm: char. self at: char put: newForm. ^ newForm. ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 1/7/2005 11:09'! glyphInfoOf: char into: glyphInfoArray | newForm | self hasCached: char ifTrue: [:form :index | self access: char at: index. glyphInfoArray at: 1 put: form; at: 2 put: 0; at: 3 put: form width; at: 4 put: (self ascentOf: char); at: 5 put: self. ^ glyphInfoArray. ]. newForm _ self computeForm: char. self at: char put: newForm. glyphInfoArray at: 1 put: newForm; at: 2 put: 0; at: 3 put: newForm width; at: 4 put: (self ascentOf: char); at: 5 put: self. ^ glyphInfoArray. ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:39'! hasCached: char ifTrue: twoArgBlock | value elem | value _ char asciiValue. self cache size to: 1 by: -1 do: [:i | elem _ self cache at: i. (elem first = value and: [elem second = foregroundColor]) ifTrue: [ ^ twoArgBlock value: elem third value: i. ]. ]. ^ false. ! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/29/2003 15:01'! isTTCFont ^true! ! !MultiTTCFont methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:30'! widthOf: char "This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation." | newForm | self hasCached: char ifTrue: [:form :index | self access: char at: index. ^ form width. ]. newForm _ self computeForm: char. self at: char put: newForm. ^ newForm width. ! ! !MultiTTCFont class methodsFor: 'as yet unclassified' stamp: 'yo 12/10/2002 18:34'! cacheAllNil " self cacheAllNil " self allInstances do: [:inst | inst cache do: [:e | e third ifNotNil: [^ false]. ]. ]. ^ true. ! ! !MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'! composeEachRectangleIn: rectangles | myLine lastChar | 1 to: rectangles size do: [:i | currCharIndex <= theText size ifFalse: [^false]. myLine _ scanner composeFrom: currCharIndex inRectangle: (rectangles at: i) firstLine: isFirstLine leftSide: i=1 rightSide: i=rectangles size. lines addLast: myLine. presentationLines addLast: scanner getPresentationLine. presentation ifNil: [presentation _ scanner getPresentation] ifNotNil: [presentation _ presentation, scanner getPresentation]. actualHeight _ actualHeight max: myLine lineHeight. "includes font changes" currCharIndex _ myLine last + 1. lastChar _ theText at: myLine last. lastChar = Character cr ifTrue: [^#cr]. wantsColumnBreaks ifTrue: [ lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. ]. ]. ^false! ! !MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/23/2003 12:53'! getPresentationInfo ^ Array with: presentationLines with: presentation. ! ! !MultiTextComposer methodsFor: 'as yet unclassified' stamp: 'yo 1/16/2003 17:30'! multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks wantsColumnBreaks _ argWantsColumnBreaks. lines _ argLinesCollection. presentationLines _ argLinesCollection copy. theTextStyle _ argTextStyle. theText _ argText. theContainer _ argContainer. deltaCharIndex _ argDelta. currCharIndex _ startCharIndex _ argStart. stopCharIndex _ argStop. prevLines _ argPriorLines. currentY _ argStartY. defaultLineHeight _ theTextStyle lineGrid. maxRightX _ theContainer left. possibleSlide _ stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle]. nowSliding _ false. prevIndex _ 1. scanner _ MultiCompositionScanner new text: theText textStyle: theTextStyle. scanner wantsColumnBreaks: wantsColumnBreaks. isFirstLine _ true. self composeAllLines. isFirstLine ifTrue: ["No space in container or empty text" self addNullLineWithIndex: startCharIndex andRectangle: (theContainer topLeft extent: 0@defaultLineHeight) ] ifFalse: [ self fixupLastLineIfCR ]. ^{lines asArray. maxRightX} ! ! !MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 21:23'! getListItem: index ^listSource getListRow: index! ! !MulticolumnLazyListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/18/2001 16:43'! listChanged columnWidths := nil. super listChanged! ! !MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'nk 1/10/2004 16:19'! display: items atRow: row on: canvas "display the specified item, which is on the specified row; for Multicolumn lists, items will be a list of strings" | drawBounds | drawBounds := self drawBoundsForRow: row. drawBounds := drawBounds intersect: self bounds. items with: (1 to: items size) do: [:item :index | "move the bounds to the right at each step" index > 1 ifTrue: [drawBounds := drawBounds left: drawBounds left + 6 + (columnWidths at: index - 1)]. item isText ifTrue: [canvas drawString: item in: drawBounds font: (font emphasized: (item emphasisAt: 1)) color: (self colorForRow: row)] ifFalse: [canvas drawString: item in: drawBounds font: font color: (self colorForRow: row)]]! ! !MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 21:58'! drawOn: aCanvas self getListSize = 0 ifTrue:[ ^self ]. self setColumnWidthsFor: aCanvas. super drawOn: aCanvas! ! !MulticolumnLazyListMorph methodsFor: 'drawing' stamp: 'sps 3/23/2004 15:51'! setColumnWidthsFor: aCanvas | row topRow bottomRow | "set columnWidths for drawing on the specified canvas" columnWidths ifNil: [ columnWidths := (self item: 1) collect: [ :ignored | 0 ]. ]. topRow := (self topVisibleRowForCanvas: aCanvas) max: 1. bottomRow := (self bottomVisibleRowForCanvas: aCanvas) max: 1. topRow > bottomRow ifTrue: [ ^ self ]. topRow to: bottomRow do: [ :rowIndex | row := self item: rowIndex. columnWidths := columnWidths with: row collect: [ :currentWidth :item | | widthOfItem | widthOfItem := (font widthOfStringOrText: item). widthOfItem > currentWidth ifTrue: [ self changed. widthOfItem ] ifFalse: [ currentWidth ] ] ]! ! !MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'sps 4/2/2004 12:16'! hUnadjustedScrollRange "multi column list morphs don't use hScrollbars" ^0 ! ! !MulticolumnLazyListMorph methodsFor: 'scroll range' stamp: 'ls 4/17/2004 12:21'! widthToDisplayItem: item | widths | widths := item collect: [ :each | super widthToDisplayItem: each ]. ^widths sum + (10 * (widths size - 1)) "add in space between the columns" ! ! !MulticolumnLazyListMorph commentStamp: '<historical>' prior: 0! A variant of LazyListMorph that can display multi-column lists.! !MultiuserTinyPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryVeryLightGray! ! !MultiuserTinyPaint methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:52'! initialize "initialize the state of the receiver" super initialize. "" drawState _ IdentityDictionary new. self clear! ! !MultiuserTinyPaint methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:55'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'clear' translated action: #clear. aCustomMenu add: 'pen color' translated action: #setPenColor:. aCustomMenu add: 'pen size' translated action: #setPenSize:. " aCustomMenu add: 'fill' translated action: #fill:." ! ! !MvcTextEditor commentStamp: 'tween 8/27/2004 12:24' prior: 0! A subclass of AppRegistry which allows the user, or Browser add-ons, to control which class is used when creating the code editing view in mvc Browsers! !MyResumableTestError methodsFor: 'exceptionDescription' stamp: 'tfei 6/13/1999 00:46'! isResumable ^true! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 12:36'! defaultAction "Backward compatibility" | response | response _ (PopUpMenu labels: 'Retry\Give Up' withCRs) startUpWithCaption: self messageText. ^ response = 2 ifFalse: [self retry]! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! hostName ^ hostName! ! !NameLookupFailure methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! hostName: aString hostName _ aString! ! !NameLookupFailure commentStamp: 'mir 5/12/2003 18:16' prior: 0! Signals that a name lookup operation failed. hostName hostName for which the name loopup failed ! !NameLookupFailure class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:57'! hostName: aString ^ self new hostName: aString! ! !NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0! Shows the name of the morph in the halo. ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:15'! generics ^generics ifNil: [generics := Dictionary new]! ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:27'! localeID ^id! ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:26'! localeID: anID id := anID! ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:17'! name: formName form: translatedForm self generics at: formName put: translatedForm. ! ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 14:02'! saveFormsOn: aStream | rr | rr _ ReferenceStream on: aStream. rr nextPut: {id isoString. generics}. rr close. ! ! !NaturalLanguageFormTranslator methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:35'! translate: aString ^ (self generics at: aString ifAbsent: [nil]) deepCopy. "Do you like to write 'form ifNotNil: [form deepCopy]'?" ! ! !NaturalLanguageFormTranslator class methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:13'! cachedTranslations "CachedTranslations := nil" ^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! ! !NaturalLanguageFormTranslator class methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:13'! isoLanguage: isoLanguage "Return the generic language translator as there is no information about the country code" ^self isoLanguage: isoLanguage isoCountry: nil! ! !NaturalLanguageFormTranslator class methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:13'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !NaturalLanguageFormTranslator class methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 14:02'! loadFormsFrom: aStream | rr pair inst | rr _ ReferenceStream on: aStream. pair _ rr next. inst _ self localeID: (LocaleID isoString: pair first). pair second associationsDo: [:assoc | inst name: assoc key form: assoc value. ]. ^ inst. ! ! !NaturalLanguageFormTranslator class methodsFor: 'as yet unclassified' stamp: 'yo 1/13/2005 11:13'! localeID: localeID ^ self cachedTranslations at: localeID ifAbsentPut: [self new localeID: localeID]! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 8/13/2004 21:12'! displayLanguage ^ id displayLanguage! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'dgd 10/7/2004 20:50'! displayName ^ id displayName! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:41'! isoCountry ^self localeID isoCountry! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'! isoLanguage ^self localeID isoLanguage! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:42'! localeID ^id! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:00'! translations ^self generics! ! !NaturalLanguageTranslator methodsFor: 'accessing' stamp: 'mir 7/21/2004 17:03'! untranslated | translations | translations := self translations. ^self class allKnownPhrases reject: [:each | translations includesKey: each]! ! !NaturalLanguageTranslator methodsFor: 'initialize-release' stamp: 'mir 7/15/2004 14:41'! localeID: anID id := anID! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/21/2004 18:02'! checkPhrase: phrase translation: translation! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 7/30/2004 13:03'! phrase: phraseString translation: translationString self generics at: phraseString put: translationString asString. self changed: #translations. self changed: #untranslated.! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/2/2004 12:27'! rawPhrase: phraseString translation: translationString self generics at: phraseString put: translationString asString. ! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'! rawRemoveUntranslated: untranslated self class allKnownPhrases removeKey: untranslated ifAbsent: []. self changed: #untranslated.! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 8/1/2004 01:07'! removeTranslationFor: phraseString self generics removeKey: phraseString ifAbsent: []. self changed: #translations. self changed: #untranslated.! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'yo 1/14/2005 16:25'! removeUntranslated: untranslated self class allKnownPhrases removeKey: untranslated ifAbsent: []. ! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/15/2004 14:34'! translate: aString ^self generics at: aString ifAbsent: [self localeID hasParent ifTrue: [(self class localeID: self localeID parent) translate: aString] ifFalse: [aString]]! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 6/30/2004 20:22'! translate: aString in: aContext! ! !NaturalLanguageTranslator methodsFor: 'translation' stamp: 'mir 7/15/2004 14:58'! translationFor: aString ^self translate: aString! ! !NaturalLanguageTranslator methodsFor: 'user interface' stamp: 'dgd 8/13/2004 21:54'! defaultBackgroundColor "answer the receiver's defaultBackgroundColor for views" ^ Color cyan! ! !NaturalLanguageTranslator methodsFor: 'private' stamp: 'mir 6/30/2004 20:23'! generics ^generics ifNil: [generics := Dictionary new]! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 7/30/2004 13:00'! loadFromFileNamed: fileNameString "Load translations from an external file" | stream | [stream := FileStream readOnlyFileNamed: fileNameString. self loadFromStream: stream] ensure: [stream close]. self changed: #translations. self changed: #untranslated. ! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'tak 11/16/2004 12:37'! loadFromRefStream: stream "Load translations from an external file" | loadedArray refStream | refStream := ReferenceStream on: stream. [loadedArray := refStream next] ensure: [refStream close]. self processExternalObject: loadedArray ! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'tak 11/16/2004 12:39'! loadFromStream: stream "Load translations from an external file" | header isFileIn | header := '''Translation dictionary'''. isFileIn := (stream next: header size) = header. stream reset. isFileIn ifTrue: [stream fileInAnnouncing: 'Loading ' , stream localName] ifFalse: [self loadFromRefStream: stream]! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 8/2/2004 12:27'! mergeTranslations: newTranslations "Merge a new set of translations into the exiting table. Overwrites existing entries." newTranslations keysAndValuesDo: [:key :value | self rawPhrase: (self class registeredPhraseFor: key) translation: value]. self changed: #translations. self changed: #untranslated.! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'mir 7/15/2004 20:04'! processExternalObject: anArray "pivate - process the external object" "new format -> {translations. untranslated}" anArray second do: [:each | self class registerPhrase: each]. self mergeTranslations: anArray first! ! !NaturalLanguageTranslator methodsFor: 'private store-retrieve' stamp: 'yo 2/17/2005 15:45'! saveToFileNamed: fileNameString "save the receiver's translations to a file named fileNameString" | stream | "Set true if you need to save as binary" false ifTrue: [stream := ReferenceStream fileNamed: fileNameString. stream nextPut: {self translations. self untranslated}. stream close. ^ self]. stream := FileStream fileNamed: fileNameString. [self fileOutOn: stream] ensure: [stream close]! ! !NaturalLanguageTranslator methodsFor: 'printing' stamp: 'nk 8/29/2004 10:51'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; print: self localeID; nextPut: $)! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/16/2004 11:04'! fileOutHeader ^ '''Translation dictionary'''! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/28/2004 14:50'! fileOutHeaderOn: aStream aStream nextChunkPut: self fileOutHeader; cr. aStream timeStamp; cr. aStream nextPut: $!!. aStream nextChunkPut: '(' , self class name , ' localeID: ' , id storeString , ')'. aStream cr! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/28/2004 14:55'! fileOutOn: aStream "self current fileOutOn: Transcript. Transcript endEntry" self fileOutOn: aStream keys: nil! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/28/2004 14:54'! fileOutOn: aStream keys: keys "self current fileOutOn: Transcript. Transcript endEntry" self fileOutHeaderOn: aStream. (keys ifNil: [generics keys asSortedCollection]) do: [:key | self nextChunkPut: (generics associationAt: key) on: aStream]. keys ifNil: [self untranslated do: [:each | self nextChunkPut: each -> '' on: aStream]]. aStream nextPut: $!!; cr! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 11/16/2004 09:26'! nextChunkPut: anObject on: aStream | i remainder terminator | terminator := $!!. remainder := anObject storeString. [(i := remainder indexOf: terminator) = 0] whileFalse: [aStream nextPutAll: (remainder copyFrom: 1 to: i). aStream nextPut: terminator. "double imbedded terminators" remainder := remainder copyFrom: i + 1 to: remainder size]. aStream nextPutAll: remainder. aStream nextPut: terminator; cr.! ! !NaturalLanguageTranslator methodsFor: 'fileIn/fileOut' stamp: 'tak 12/15/2004 16:07'! scanFrom: aStream "Read a definition of dictionary. Make sure current locale corresponds my locale id" | aString newTranslations assoc currentPlatform | newTranslations := Dictionary new. currentPlatform := Locale currentPlatform. [Locale currentPlatform: (Locale localeID: id). [aString := aStream nextChunk withSqueakLineEndings. aString size > 0] whileTrue: [assoc := Compiler evaluate: aString. assoc value = '' ifTrue: [self class registerPhrase: assoc key] ifFalse: [newTranslations add: assoc]]] ensure: [Locale currentPlatform: currentPlatform]. self mergeTranslations: newTranslations! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 20:20'! availableLanguageLocaleIDs "Return the locale ids for the currently available languages. Meaning those which either internally or externally have translations available." "NaturalLanguageTranslator availableLanguageLocaleIDs" ^ CachedTranslations values collect:[:each | each localeID]! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:39'! current ^ LocaleID current translator ! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'nk 8/29/2004 14:23'! default ^self localeID: (LocaleID default) ! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'! isoLanguage: isoLanguage "Return the generic language translator as there is no information about the country code" ^self isoLanguage: isoLanguage isoCountry: nil! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:36'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !NaturalLanguageTranslator class methodsFor: 'accessing' stamp: 'dgd 8/24/2004 19:18'! localeID: localeID ^ self cachedTranslations at: localeID ifAbsentPut: [self new localeID: localeID]! ! !NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'mir 8/11/2004 13:38'! initialize "NaturalLanguageTranslator initialize" FileList registerFileReader: self. Smalltalk addToStartUpList: NaturalLanguageTranslator after: FileDirectory. ! ! !NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'mir 7/15/2004 19:48'! resetCaches "NaturalLanguageTranslator resetCaches" CachedTranslations := nil. ! ! !NaturalLanguageTranslator class methodsFor: 'class initialization' stamp: 'nk 8/29/2004 13:23'! startUp: resuming | defaultID | resuming ifFalse: [^ self]. "" defaultID := LocaleID default. self cachedTranslations at: defaultID ifAbsent: [self localeID: defaultID]. "" self loadAvailableExternalLocales! ! !NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 8/11/2004 10:52'! fileReaderServicesForFile: fullName suffix: suffix "Answer the file services associated with given file" ^ (suffix = self translationSuffix) | (suffix = '*') ifTrue: [{self serviceMergeLanguageTranslations}] ifFalse: [#()]! ! !NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'yo 2/24/2005 21:04'! mergeTranslationFileNamed: fileFullNameString "merge the translation in the file named fileFullNameString" | stream localeID translator | stream := FileStream readOnlyFileNamed: fileFullNameString. [localeID := LocaleID isoString: stream localName sansPeriodSuffix. translator := self localeID: localeID. translator loadFromStream: stream] ensure: [stream close]. LanguageEnvironment resetKnownEnvironments. ! ! !NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'! serviceMergeLanguageTranslations "Answer a service for merging of translation files" ^ SimpleServiceEntry provider: self label: 'merge the translation file' selector: #mergeTranslationFileNamed: description: 'merge the translation file into the language named like the file' buttonLabel: 'merge'! ! !NaturalLanguageTranslator class methodsFor: 'file-services' stamp: 'mir 7/21/2004 13:45'! services "Answer potential file services associated with this class" ^ {self serviceMergeLanguageTranslations}! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:03'! directoryForLanguage: isoLanguage country: isoCountry create: createDir "Try to locate the <prefs>/locale/<language>{/<country>} folder. If createDir is set, create the path down to country or language, depending on wether it's specified.. Return the directory for country or language depending on specification. If neither exists, nil" "NaturalLanguageTranslator directoryForLanguage: 'es' country: nil create: true" "NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' create: true" "NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' create: false" "NaturalLanguageTranslator directoryForLanguage: 'en' country: nil create: true" "If this fails, there is nothing we can do about it here" | localeDir countryDir languageDir | localeDir := self localeDirCreate: createDir. localeDir ifNil: [^nil]. isoCountry ifNil: [ languageDir := localeDir directoryNamed: isoLanguage. createDir ifTrue: [languageDir assureExistence]. ^languageDir exists ifTrue: [languageDir] ifFalse: [nil]]. countryDir := languageDir directoryNamed: isoCountry. createDir ifTrue: [countryDir assureExistence]. ^countryDir exists ifTrue: [countryDir] ifFalse: [nil]! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/11/2004 10:44'! directoryForLocaleID: localeID create: createDir "Try to locate the <prefs>/locale/<language>{/<country>} folder. If createDir is set, create the path down to country or language, depending on locale. Return the directory for country or language depending on locale. If neither exists, nil" "NaturalLanguageTranslator directoryForLanguage: 'de' country: nil readOnly: true" "NaturalLanguageTranslator directoryForLanguage: 'de' country: 'DE' readOnly: true" "NaturalLanguageTranslator directoryForLanguage: 'en' country: 'US' readOnly: false" "NaturalLanguageTranslator directoryForLanguage: 'en' country: nil readOnly: true" ^self directoryForLanguage: localeID isoLanguage country: localeID isoCountry create: createDir! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:57'! loadAvailableExternalLocales "private - register locales IDs based on the content of the <prefs>/locale/ directory" | localeDir | localeDir := self localeDirCreate: false. localeDir ifNil: [^ #()]. localeDir directoryNames do: [:langDirName | | langDir | langDir := localeDir directoryNamed: langDirName. (langDir fileNamesMatching: '*.' , self translationSuffix) ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: nil]. langDir directoryNames do: [:countryDirName | | countryDir | countryDir := langDirName directoryNamed: countryDirName. (countryDir fileNamesMatching: '*.' , self translationSuffix) ifNotEmpty: [self loadTranslatorForIsoLanguage: langDirName isoCountry: countryDirName] ] ]. ! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'nk 8/21/2004 13:00'! loadExternalTranslationsFor: translator "Try to load translations from external external files. The files are located in the <prefs>/locale/<language>{/<country>} folder. There can be more than one file for each location, so applications can install their own partial translation tables. All files in the specific folder are loaded." | translationDir | translationDir := self directoryForLocaleID: translator localeID create: false. translationDir ifNil: [ ^nil ]. (translationDir fileNamesMatching: '*.' , self translationSuffix) do: [:fileName | translator loadFromFileNamed: (translationDir fullNameFor: fileName)]! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 11:59'! loadTranslatorForIsoLanguage: isoLanguage isoCountry: isoCountry "private - load the translations from <prefs>/locale/ directory the procedure is to assure the existence of a translator for the given language/country and then load the external translations for this translator" | translator | translator := self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry). self loadExternalTranslationsFor: translator! ! !NaturalLanguageTranslator class methodsFor: 'private loading' stamp: 'mir 8/25/2004 12:03'! localeDirCreate: createDir "Try to locate the <prefs>/locale/ folder. If createDir is set, try to create the path. If it doesn't exist, return nil" "If this fails, there is nothing we can do about it here" | prefDir localeDir | (createDir not and: [ExternalSettings preferenceDirectory isNil]) ifTrue: [^ nil]. prefDir := ExternalSettings assuredPreferenceDirectory. prefDir exists ifFalse: [^nil]. localeDir := prefDir directoryNamed: 'locale'. createDir ifTrue: [localeDir assureExistence]. ^localeDir exists ifTrue: [localeDir] ifFalse: [nil]! ! !NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 19:58'! allKnownPhrases ^AllKnownPhrases ifNil: [AllKnownPhrases := Dictionary new: 2051]! ! !NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/13/2004 00:06'! cachedTranslations "CachedTranslations := nil" ^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! ! !NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/15/2004 20:02'! registerPhrase: phrase "Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation." self allKnownPhrases at: phrase put: phrase! ! !NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 7/21/2004 14:18'! registeredPhraseFor: phrase "Using a Dictionary so we can lookup existing string instead of creating needless copies when loading a translation." ^self allKnownPhrases at: phrase ifAbsentPut: [phrase]! ! !NaturalLanguageTranslator class methodsFor: 'private' stamp: 'mir 8/11/2004 10:52'! translationSuffix ^'translation'! ! !NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! showAndClearStats: queueName DEBUG ifNil: [^Beeper beep]. self showStats: queueName from: DEBUG. DEBUG _ nil.! ! !NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! showStats DEBUG ifNil: [^Beeper beep]. DEBUG explore.! ! !NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! showStats: queueName DEBUG ifNil: [^Beeper beep]. self showStats: queueName from: DEBUG. ! ! !NebraskaDebug class methodsFor: 'as yet unclassified' stamp: 'nb 6/17/2003 12:25'! stopAndShowAll | prev | self halt. "not updated to new format" prev _ DEBUG. DEBUG _ nil. prev ifNil: [^Beeper beep]. prev keysAndValuesDo: [ :k :v | self showStats: k from: v ].! ! !NebraskaNavigationMorph methodsFor: 'as yet unclassified' stamp: 'yo 11/4/2002 21:06'! fontForButtons ^ TextStyle defaultFont. "^Preferences standardButtonFont"! ! !NebraskaNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/16/2003 14:11'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow ! ! !NebraskaServer class methodsFor: 'instance creation' stamp: 'mu 11/28/2003 19:38'! newForWorld: aWorld ^self basicNew initializeForWorld: aWorld! ! !NebraskaServerMorph methodsFor: 'accessing' stamp: 'RAA 5/31/2001 15:03'! currentBacklogString ^currentBacklogString! ! !NebraskaServerMorph methodsFor: 'drawing' stamp: 'yo 7/2/2004 18:39'! updateCurrentStatusString self server ifNil:[ currentStatusString _ '<Nebraska not active>' translated. currentBacklogString _ ''. ] ifNotNil:[ currentStatusString _ ' Nebraska: ' translated, self server numClients printString, ' clients' translated. currentBacklogString _ 'backlog: ' translated, ((previousBacklog _ self server backlog) // 1024) printString,'k' ]. ! ! !NebraskaServerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !NebraskaServerMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:29'! initialize "initialize the state of the receiver" super initialize. "" fullDisplay _ false. lastFullUpdateTime _ 0. self listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap! ! !NebraskaServerMorph methodsFor: 'initialization' stamp: 'yo 7/2/2004 18:38'! rebuild | myServer toggle closeBox font | font _ StrikeFont familyName: #Palatino size: 14. self removeAllMorphs. self setColorsAndBorder. self updateCurrentStatusString. toggle _ SimpleHierarchicalListMorph new perform: ( fullDisplay ifTrue: [#expandedForm] ifFalse: [#notExpandedForm] ). closeBox _ SimpleButtonMorph new borderWidth: 0; label: 'X' font: Preferences standardButtonFont; color: Color transparent; actionSelector: #delete; target: self; extent: 14@14; setBalloonText: 'End Nebrasks session'. self addARow: { self inAColumn: {closeBox}. self inAColumn: { UpdatingStringMorph new useStringFormat; target: self; font: font; getSelector: #currentStatusString; contents: self currentStatusString; stepTime: 2000; lock. }. self inAColumn: { toggle asMorph on: #mouseUp send: #toggleFull to: self; setBalloonText: 'Show more or less of Nebraska Status' }. }. myServer _ self server. (myServer isNil or: [fullDisplay not]) ifTrue: [ ^World startSteppingSubmorphsOf: self ]. "--- the expanded display ---" self addARow: { self inAColumn: { UpdatingStringMorph new useStringFormat; target: self; font: font; getSelector: #currentBacklogString; contents: self currentBacklogString; stepTime: 2000; lock. }. }. self addARow: { self inAColumn: { (StringMorph contents: '--clients--' translated) lock; font: font. }. }. myServer clients do: [ :each | self addARow: { UpdatingStringMorph new useStringFormat; target: each; font: font; getSelector: #currentStatusString; contents: each currentStatusString; stepTime: 2000; lock. } ]. World startSteppingSubmorphsOf: self.! ! !NebraskaServerMorph methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:35'! setColorsAndBorder | worldColor c | c := ((Preferences menuColorFromWorld and: [Display depth > 4]) and: [(worldColor := self currentWorld color) isColor]) ifTrue: [worldColor luminance > 0.7 ifTrue: [worldColor mixed: 0.8 with: Color black] ifFalse: [worldColor mixed: 0.4 with: Color white]] ifFalse: [Preferences menuColor]. self color: c. self borderColor: #raised. self borderWidth: Preferences menuBorderWidth. self useRoundedCorners! ! !NebraskaServerMorph class methodsFor: 'as yet unclassified' stamp: 'wiz 1/9/2005 15:12'! serveWorld: aWorld "Check to make sure things won't crash. See Mantis #0000519" aWorld isSafeToServe ifTrue:[ ^self serveWorld: aWorld onPort: NebraskaServer defaultPort] ! ! !NetNameResolver commentStamp: '<historical>' prior: 0! This class implements TCP/IP style network name lookup and translation facilities. Attempt to keep track of whether there is a network available. HaveNetwork true if last attempt to contact the network was successful. LastContact Time of that contact (totalSeconds). haveNetwork returns true, false, or #expired. True means there was contact in the last 30 minutes. False means contact failed or was false last time we asked. Get out of false state by making contact with a server in some way (FileList or updates).! !NetNameResolver class methodsFor: 'lookups' stamp: 'mu 9/7/2003 22:53'! addressForName: hostName timeout: secs "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" "NetNameResolver addressForName: '100000jobs.de' timeout: 30" "NetNameResolver addressForName: '1.7.6.4' timeout: 30" "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" | deadline result | self initializeNetwork. "check if this is a valid numeric host address (e.g. 1.2.3.4)" result _ self addressFromString: hostName. result isNil ifFalse: [^result]. "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" deadline _ Time millisecondClockValue + (secs * 1000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." self resolverMutex critical: [ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfName: hostName. (self waitForCompletionUntil: deadline) ifTrue: [result _ self primNameLookupResult] ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]] ifFalse: [(NameLookupFailure hostName: hostName) signal: 'Could not resolve the server named: ', hostName]]. ^result! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:50'! localHostAddress "Return the local address of this host." "NetNameResolver localHostAddress" self initializeNetwork. ^ self primLocalAddress ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'mir 2/22/2002 15:12'! localHostName "Return the local name of this host." "NetNameResolver localHostName" | hostName | hostName _ NetNameResolver nameForAddress: self localHostAddress timeout: 5. ^hostName ifNil: [self localAddressString] ifNotNil: [hostName]! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'nk 6/27/2003 10:51'! nameForAddress: hostAddress timeout: secs "Look up the given host address and return its name. Return nil if the lookup fails or is not completed in the given number of seconds. Depends on the given host address being known to the gateway, which may not be the case for dynamically allocated addresses." "NetNameResolver nameForAddress: (NetNameResolver addressFromString: '128.111.92.2') timeout: 30" | deadline result | self initializeNetwork. deadline _ Time millisecondClockValue + (secs * 1000). "Protect the execution of this block, as the ResolverSemaphore is used for both parts of the transaction." self resolverMutex critical: [ result _ (self waitForResolverReadyUntil: deadline) ifTrue: [ self primStartLookupOfAddress: hostAddress. (self waitForCompletionUntil: deadline) ifTrue: [self primAddressLookupResult] ifFalse: [nil]] ifFalse: [nil]]. ^result ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'mu 9/8/2003 14:24'! promptUserForHostAddressDefault: defaultName "Ask the user for a host name and return its address. If the default name is the empty string, use the last host name as the default." "NetNameResolver promptUserForHostAddressDefault: ''" | default hostName serverAddr | defaultName isEmpty ifTrue: [default _ DefaultHostName] ifFalse: [default _ defaultName]. hostName _ FillInTheBlank request: 'Host name or address?' initialAnswer: default. hostName isEmpty ifTrue: [^ 0]. serverAddr _ NetNameResolver addressForName: hostName timeout: 15. hostName size > 0 ifTrue: [DefaultHostName _ hostName]. ^ serverAddr! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'mir 2/22/2002 15:03'! initializeNetwork "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails." "NetNameResolver initializeNetwork" | semaIndex | self resolverStatus = ResolverUninitialized ifFalse: [^HaveNetwork _ true]. "network is already initialized" HaveNetwork _ false. "in case abort" ResolverSemaphore _ Semaphore new. semaIndex _ Smalltalk registerExternalObject: ResolverSemaphore. "result is nil if network initialization failed, self if it succeeds" (self primInitializeNetwork: semaIndex) ifNil: [NoNetworkError signal: 'failed network initialization'] ifNotNil: [HaveNetwork _ true]. ! ! !NetNameResolver class methodsFor: 'private' stamp: 'mir 6/18/2001 21:05'! resolverMutex ResolverMutex ifNil: [ResolverMutex _ Semaphore forMutualExclusion]. ^ResolverMutex! ! !NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0! Abstract super class for all network related exceptions.! !NetworkTerminalMorph methodsFor: 'layout' stamp: 'RAA 3/7/2001 22:32'! acceptDroppingMorph: morphToDrop event: evt | myCopy outData null | (morphToDrop isKindOf: NewHandleMorph) ifTrue: [ "don't send these" ^morphToDrop rejectDropMorphEvent: evt. ]. self eToyRejectDropMorph: morphToDrop event: evt. "we don't really want it" "7 mar 2001 - remove #veryDeepCopy" myCopy _ morphToDrop. "gradient fills require doing this second" myCopy setProperty: #positionInOriginatingWorld toValue: morphToDrop position. outData _ myCopy eToyStreamedRepresentationNotifying: nil. null _ String with: 0 asCharacter. EToyPeerToPeer new sendSomeData: { EToyIncomingMessage typeMorph,null. Preferences defaultAuthorName,null. outData } to: (NetNameResolver stringFromAddress: connection remoteAddress) for: self. ! ! !NetworkTerminalMorph class methodsFor: 'instance creation' stamp: 'mir 5/15/2003 18:06'! socketConnectedTo: serverHost port: serverPort | sock | Socket initializeNetwork. sock _ Socket new. [sock connectTo: (NetNameResolver addressForName: serverHost) port: serverPort] on: ConnectionTimedOut do: [:ex | self error: 'could not connect to server' ]. ^StringSocket on: sock ! ! !NewHandleMorph methodsFor: 'all' stamp: 'ar 8/16/2001 15:48'! followHand: aHand forEachPointDo: block1 lastPointDo: block2 withCursor: aCursor hand _ aHand. hand showTemporaryCursor: aCursor "hotSpotOffset: aCursor offset negated". borderWidth _ 0. color _ Color transparent. pointBlock _ block1. lastPointBlock _ block2. self position: hand lastEvent cursorPoint - (self extent // 2)! ! !NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'! sensorMode "If our client is still addressing the Sensor directly, we need to do so as well" ^self valueOfProperty: #sensorMode ifAbsent: [false]. ! ! !NewHandleMorph methodsFor: 'all' stamp: 'RAA 4/19/2001 11:36'! sensorMode: aBoolean "If our client is still addressing the Sensor directly, we need to do so as well" self setProperty: #sensorMode toValue: aBoolean. ! ! !NewHandleMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:29'! initialize "initialize the state of the receiver" super initialize. "" waitingForClickInside _ true. Preferences noviceMode ifTrue: [self setBalloonText: 'stretch']! ! !NewHandleMorph methodsFor: 'stepping and presenter' stamp: 'RAA 4/19/2001 11:37'! step | eventSource | eventSource _ self sensorMode ifTrue: [ Sensor ] ifFalse: [ hand lastEvent ]. eventSource anyButtonPressed ifTrue: [waitingForClickInside _ false. self position: eventSource cursorPoint - (self extent // 2). pointBlock value: self center] ifFalse: [waitingForClickInside ifTrue: [(self containsPoint: eventSource cursorPoint) ifFalse: ["mouse wandered out before clicked" ^ self delete]] ifFalse: [lastPointBlock value: self center. ^ self delete]]! ! !NewHandleMorph methodsFor: 'submorphs-add/remove' stamp: 'ar 8/16/2001 15:38'! delete hand ifNotNil:[ hand showTemporaryCursor: nil. ]. super delete.! ! !NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:42'! focused focused ifNil: [focused := false]. ^ focused! ! !NewParagraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:41'! focused: aBoolean focused := aBoolean! ! !NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'! wantsColumnBreaks ^wantsColumnBreaks! ! !NewParagraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'! wantsColumnBreaks: aBoolean wantsColumnBreaks _ aBoolean! ! !NewParagraph methodsFor: 'composition' stamp: 'jm 2/25/2003 16:20'! OLDcomposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine | charIndex := start. lines := lineColl. lineY := startingY. lineHeightGuess := textStyle lineGrid. maxRightX := container left. maybeSlide := stop < text size and: [container isMemberOf: Rectangle]. sliding := false. priorIndex := 1. bottom := container bottom. scanner := CompositionScanner new text: text textStyle: textStyle. firstLine := true. [charIndex <= text size and: [lineY + lineHeightGuess <= bottom]] whileTrue: [sliding ifTrue: ["Having detected the end of rippling recoposition, we are only sliding old lines" priorIndex < priorLines size ifTrue: ["Adjust and re-use previously composed line" priorIndex := priorIndex + 1. priorLine := (priorLines at: priorIndex) slideIndexBy: delta andMoveTopTo: lineY. lineColl addLast: priorLine. lineY := priorLine bottom. charIndex := priorLine last + 1] ifFalse: ["There are no more priorLines to slide." sliding := maybeSlide := false]] ifFalse: [lineHeight := lineHeightGuess. saveCharIndex := charIndex. hitCR := false. row := container rectanglesAt: lineY height: lineHeight. 1 to: row size do: [:i | (charIndex <= text size and: [hitCR not]) ifTrue: [line := scanner composeFrom: charIndex inRectangle: (row at: i) firstLine: firstLine leftSide: i = 1 rightSide: i = row size. lines addLast: line. (text at: line last) = Character cr ifTrue: [hitCR := true]. lineHeight := lineHeight max: line lineHeight. "includes font changes" charIndex := line last + 1]]. lineY := lineY + lineHeight. row notEmpty ifTrue: [lineY > bottom ifTrue: ["Oops -- the line is really too high to fit -- back out" charIndex := saveCharIndex. row do: [:r | lines removeLast]] ifFalse: ["It's OK -- the line still fits." maxRightX := maxRightX max: scanner rightX. 1 to: row size - 1 do: [:i | "Adjust heights across row if necess" (lines at: lines size - row size + i) lineHeight: lines last lineHeight baseline: lines last baseline]. charIndex > text size ifTrue: ["end of text" hitCR ifTrue: ["If text ends with CR, add a null line at the end" lineY + lineHeightGuess <= container bottom ifTrue: [row := container rectanglesAt: lineY height: lineHeightGuess. row notEmpty ifTrue: [line := (TextLine start: charIndex stop: charIndex - 1 internalSpaces: 0 paddingWidth: 0) rectangle: row first; lineHeight: lineHeightGuess baseline: textStyle baseline. lines addLast: line]]]. lines := lines asArray. ^maxRightX]. firstLine := false]]. (maybeSlide and: [charIndex > stop]) ifTrue: ["Check whether we are now in sync with previously composed lines" [priorIndex < priorLines size and: [(priorLines at: priorIndex) first < (charIndex - delta)]] whileTrue: [priorIndex := priorIndex + 1]. (priorLines at: priorIndex) first = (charIndex - delta) ifTrue: ["Yes -- next line will have same start as prior line." priorIndex := priorIndex - 1. maybeSlide := false. sliding := true] ifFalse: [priorIndex = priorLines size ifTrue: ["Weve reached the end of priorLines, so no use to keep looking for lines to slide." maybeSlide := false]]]]]. firstLine ifTrue: ["No space in container or empty text" line := (TextLine start: start stop: start - 1 internalSpaces: 0 paddingWidth: 0) rectangle: (container topLeft extent: 0 @ lineHeightGuess); lineHeight: lineHeightGuess baseline: textStyle baseline. lines := Array with: line] ifFalse: [self fixLastWithHeight: lineHeightGuess]. "end of container" lines := lines asArray. ^maxRightX! ! !NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'! composeAll text string isOctetString ifTrue: [ ^ self composeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top. ]. ^ self multiComposeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top. ! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 5/7/2001 10:58'! composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult | newResult _ TextComposer new composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines _ newResult first asArray. maxRightX _ newResult second. ^maxRightX ! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 2/25/2001 15:02'! fixLastWithHeight: lineHeightGuess "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I coul;dn't figure out where to put it in the main logic." | oldLastLine newRectangle line | (text size > 1 and: [text last = Character cr]) ifFalse: [^self]. oldLastLine _ lines last. oldLastLine last - oldLastLine first >= 0 ifFalse: [^self]. oldLastLine last = text size ifFalse: [^self]. newRectangle _ oldLastLine left @ oldLastLine bottom extent: 0@(oldLastLine bottom - oldLastLine top). "Even though we may be below the bottom of the container, it is still necessary to compose the last line for consistency..." line _ TextLine start: text size+1 stop: text size internalSpaces: 0 paddingWidth: 0. line rectangle: newRectangle. line lineHeight: lineHeightGuess baseline: textStyle baseline. lines _ lines, (Array with: line). ! ! !NewParagraph methodsFor: 'composition' stamp: 'yo 1/3/2003 12:17'! multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | newResult | newResult _ MultiTextComposer new multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY textStyle: textStyle text: text container: container wantsColumnBreaks: wantsColumnBreaks == true. lines _ newResult first asArray. maxRightX _ newResult second. "maxRightX printString displayAt: 0@0." ^maxRightX ! ! !NewParagraph methodsFor: 'composition' stamp: 'yo 12/20/2002 16:18'! recomposeFrom: start to: stop delta: delta "Recompose this paragraph. The altered portion is between start and stop. Recomposition may continue to the end of the text, due to a ripple effect. Delta is the amount by which the current text is longer than it was when its current lines were composed." | startLine newLines | "Have to recompose line above in case a word-break was affected." startLine _ (self lineIndexForCharacter: start) - 1 max: 1. [startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]] whileTrue: [startLine _ startLine - 1]. "Find leftmost of line pieces" newLines _ OrderedCollection new: lines size + 1. 1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)]. text string isOctetString ifTrue: [ ^ self composeLinesFrom: (lines at: startLine) first to: stop delta: delta into: newLines priorLines: lines atY: (lines at: startLine) top. ]. self multiComposeLinesFrom: (lines at: startLine) first to: stop delta: delta into: newLines priorLines: lines atY: (lines at: startLine) top. ! ! !NewParagraph methodsFor: 'composition' stamp: 'RAA 5/6/2001 15:09'! testNewComposeAll | newResult | self OLDcomposeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top. newResult _ TextComposer new composeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top textStyle: textStyle text: text container: container wantsColumnBreaks: false. newResult first with: lines do: [ :e1 :e2 | e1 longPrintString = e2 longPrintString ifFalse: [self halt]. ]. newResult second = maxRightX ifFalse: [self halt]. ^{newResult. {lines. maxRightX}} ! ! !NewParagraph methodsFor: 'composition' stamp: 'yo 12/17/2002 14:48'! testNewComposeAll2 | newResult | newResult _ TextComposer new composeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top textStyle: textStyle text: text container: container wantsColumnBreaks: false. ^{newResult. {lines. maxRightX}} ! ! !NewParagraph methodsFor: 'composition' stamp: 'yo 12/18/2002 15:00'! testNewComposeAll3 | newResult | newResult _ TextComposer new multiComposeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top textStyle: textStyle text: text container: (0@0 extent: 31@60) wantsColumnBreaks: false. ^{newResult. {lines. maxRightX}} ! ! !NewParagraph methodsFor: 'display' stamp: 'nk 8/31/2004 11:10'! displaySelectionInLine: line on: aCanvas | leftX rightX w caretColor | selectionStart ifNil: [^self]. "No selection" aCanvas isShadowDrawing ifTrue: [ ^self ]. "don't draw selection with shadow" selectionStart = selectionStop ifTrue: ["Only show caret on line where clicked" selectionStart textLine ~= line ifTrue: [^self]] ifFalse: ["Test entire selection before or after here" (selectionStop stringIndex < line first or: [selectionStart stringIndex > (line last + 1)]) ifTrue: [^self]. "No selection on this line" (selectionStop stringIndex = line first and: [selectionStop textLine ~= line]) ifTrue: [^self]. "Selection ends on line above" (selectionStart stringIndex = (line last + 1) and: [selectionStop textLine ~= line]) ifTrue: [^self]]. "Selection begins on line below" leftX := (selectionStart stringIndex < line first ifTrue: [line ] ifFalse: [selectionStart ])left. rightX := (selectionStop stringIndex > (line last + 1) or: [selectionStop stringIndex = (line last + 1) and: [selectionStop textLine ~= line]]) ifTrue: [line right] ifFalse: [selectionStop left]. selectionStart = selectionStop ifTrue: [rightX := rightX + 1. w := self caretWidth. caretColor := self insertionPointColor. 1 to: w do: [:i | "Draw caret triangles at top and bottom" aCanvas fillRectangle: ((leftX - w + i - 1) @ (line top + i - 1) extent: ((w - i) * 2 + 3) @ 1) color: caretColor. aCanvas fillRectangle: ((leftX - w + i - 1) @ (line bottom - i) extent: ((w - i) * 2 + 3) @ 1) color: caretColor]. aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: caretColor] ifFalse: [aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom) color: self selectionColor]! ! !NewParagraph methodsFor: 'display' stamp: 'rr 3/22/2004 19:56'! insertionPointColor self focused ifFalse: [^ Color transparent]. ^ Display depth <= 2 ifTrue: [Color black] ifFalse: [Preferences insertionPointColor]! ! !NewParagraph methodsFor: 'display' stamp: 'rr 3/23/2004 19:52'! selectionColor | color | Display depth = 1 ifTrue: [^ Color veryLightGray]. Display depth = 2 ifTrue: [^ Color gray]. color := Preferences textHighlightColor. self focused ifFalse: [color := color alphaMixed: 0.2 with: Color veryVeryLightGray]. ^ color! ! !NewParagraph methodsFor: 'editing' stamp: 'nk 3/8/2004 14:56'! clickAt: clickPoint for: model controller: editor "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | startBlock action target range boxes box | action _ false. startBlock _ self characterBlockAtPoint: clickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) do: [:att | att mayActOnClick ifTrue: [(target _ model) ifNil: [target _ editor morph]. range _ text rangeOf: att startingAt: startBlock stringIndex forStyle: textStyle. boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) to: (self characterBlockForIndex: range last+1). box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: [nil]. box ifNotNil: [ box _ (editor transformFrom: nil) invertBoundsRect: box. editor morph allOwnersDo: [ :m | box _ box intersect: (m boundsInWorld) ]. Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [(att actOnClickFor: target in: self at: clickPoint editor: editor) ifTrue: [action _ true]]. Cursor currentCursor == Cursor webLink ifTrue:[Cursor normal show]. ]]]. ^ action! ! !NewParagraph methodsFor: 'fonts-display' stamp: 'nk 3/20/2004 11:13'! displayOn: aCanvas using: displayScanner at: somePosition "Send all visible lines to the displayScanner for display" | visibleRectangle offset leftInRun line | visibleRectangle _ aCanvas clipRect. offset _ (somePosition - positionWhenComposed) truncated. leftInRun _ 0. (self lineIndexForPoint: visibleRectangle topLeft) to: (self lineIndexForPoint: visibleRectangle bottomRight) do: [:i | line _ lines at: i. self displaySelectionInLine: line on: aCanvas. line first <= line last ifTrue: [leftInRun _ displayScanner displayLine: line offset: offset leftInRun: leftInRun]]. ! ! !NewParagraph methodsFor: 'selection' stamp: 'yo 1/1/2003 15:09'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for the character in the text at aPoint." | line | line _ lines at: (self lineIndexForPoint: aPoint). ^ ((text string isKindOf: MultiString) ifTrue: [ MultiCharacterBlockScanner new text: text textStyle: textStyle ] ifFalse: [CharacterBlockScanner new text: text textStyle: textStyle]) characterBlockAtPoint: aPoint index: nil in: line! ! !NewParagraph methodsFor: 'selection' stamp: 'yo 1/1/2003 15:11'! characterBlockForIndex: index "Answer a CharacterBlock for the character in text at index." | line | line _ lines at: (self lineIndexForCharacter: index). ^ ((text string isKindOf: MultiString) ifTrue: [ MultiCharacterBlockScanner new text: text textStyle: textStyle ] ifFalse: [ CharacterBlockScanner new text: text textStyle: textStyle ]) characterBlockAtPoint: nil index: ((index max: line first) min: text size+1) in: line! ! !NewParagraph methodsFor: 'selection' stamp: 'ls 11/2/2001 23:10'! selectionRectsFrom: characterBlock1 to: characterBlock2 "Return an array of rectangles representing the area between the two character blocks given as arguments." | line1 line2 rects cb1 cb2 w | characterBlock1 <= characterBlock2 ifTrue: [cb1 _ characterBlock1. cb2 _ characterBlock2] ifFalse: [cb2 _ characterBlock1. cb1 _ characterBlock2]. cb1 = cb2 ifTrue: [w _ self caretWidth. ^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))]. line1 _ self lineIndexForCharacter: cb1 stringIndex. line2 _ self lineIndexForCharacter: cb2 stringIndex. line1 = line2 ifTrue: [^ Array with: (cb1 topLeft corner: cb2 bottomRight)]. rects _ OrderedCollection new. rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight). line1+1 to: line2-1 do: [ :i | | line | line := lines at: i. (line left = rects last left and: [ line right = rects last right ]) ifTrue: [ "new line has same margins as old one -- merge them, so that the caller gets as few rectangles as possible" | lastRect | lastRect := rects removeLast. rects add: (lastRect bottom: line bottom) ] ifFalse: [ "differing margins; cannot merge" rects add: line rectangle ] ]. rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft). ^ rects! ! !NewParagraph methodsFor: 'private' stamp: 'edc 6/18/2004 09:10'! moveBy: delta lines do: [:line | line moveBy: delta]. positionWhenComposed ifNotNil:[ positionWhenComposed _ positionWhenComposed + delta]. container _ container translateBy: delta! ! !NewParagraph methodsFor: 'initialize-release' stamp: 'tak 12/21/2004 13:29'! initialize self positionWhenComposed: 0 @ 0! ! !NewParagraph commentStamp: '<historical>' prior: 0! A Paragraph represents text that has been laid out, or composed, in some container. text A Text with encoded per-character emphasis. textStyle A TextStyle with font set, line height and horizontal alignment. firstCharacterIndex The starting index in text for this paragraph, allowing composition of a long text into a number of containers. container A Rectangle or TextContainer that determines where text can go. lines An Array of TextLines comprising the final layout of the text after it has been composed within its container. positionWhenComposed As its name implies. Allows display at new locations without the need to recompose the text. Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty. Notes on yet another hack - 5 Feb 2001 We really need to clean up #composeLinesFrom:to:delta:into:priorLines:atY:!!!!!! I added one more habdful of code to correct: This is an annoying bug that's been around for a couple of years, but I finally figured out how to duplicate the problem, so I figured I'd just report it now. (It doesn't necessarily have to be fixed for 3.0 if it looks messy, but if it's a simple fix, it would be worth it.) In Morphic, if you have the following text in a workspace: This is line 1 This is line 2 **and** you have a return character after line 2, you will normally be able to click the mouse two times below line 2 in order to select all the text. If you edit line 2 (e.g. so that it reads "line number 2"), you can still select all the text by clicking below the second line. However, if you edit line 1, you will not be able to select all the text from the bottom in the same way. Things get messed up such that the last return character seems to be gone. In this state, if you position the cursor immediately after the 2, and press the right arrow, the cursor jumps to the beginning of line 2... oof. (report by Doug Way) While I don't have a very deep understanding of the above mentioned method, I was able to determine that text ending in a CR worked better in the editor when the last entry in <lines> had a start of text size + 1 and a stop of text size. I have accordingly added code near the end to ensure this. It seems to have fixed the problem, but we do need to clean this baby up some day. - Bob ! ]style[(830 38 127 1000 388)f1,f2cblue;,f1,f1cred;,f1! !NewWorldWindow methodsFor: 'initialization' stamp: 'ar 5/11/2001 23:48'! openInWorld: aWorld | xxx | "This msg and its callees result in the window being activeOnlyOnTop" xxx _ RealEstateAgent initialFrameFor: self world: aWorld. "Bob say: 'opening in ',xxx printString,' out of ',aWorld bounds printString. 6 timesRepeat: [Display flash: xxx andWait: 300]." self bounds: xxx. ^self openAsIsIn: aWorld.! ! !NewWorldWindow methodsFor: 'label' stamp: 'sw 5/19/2001 10:44'! setStripeColorsFrom: paneColor "Since our world may be *any* color, try to avoid really dark colors so title will show" | revisedColor | stripes ifNil: [^ self]. revisedColor _ paneColor atLeastAsLuminentAs: 0.1 . self isActive ifTrue: [stripes second color: revisedColor; borderColor: stripes second color darker. stripes first color: stripes second borderColor darker; borderColor: stripes first color darker. ^ self]. "This could be much faster" stripes second color: revisedColor; borderColor: revisedColor. stripes first color: revisedColor; borderColor: revisedColor! ! !NewWorldWindow methodsFor: 'color' stamp: 'nb 6/17/2003 12:25'! setWindowColor: incomingColor | existingColor aColor | incomingColor ifNil: [^ self]. "it happens" aColor _ incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. existingColor _ self paneColorToUse. existingColor ifNil: [^ Beeper beep]. self setStripeColorsFrom: aColor ! ! !NoConversionClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 19:03'! fromSystemClipboard: aString ^ aString. ! ! !NoConversionClipboardInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 8/11/2003 21:06'! toSystemClipboard: aString | result | aString isOctetString ifTrue: [^ aString asOctetString]. result _ WriteStream on: (String new: aString size). aString do: [:each | each value < 256 ifTrue: [result nextPut: each]]. ^ result contents. ! ! !NoInputInterpreter methodsFor: 'as yet unclassified' stamp: 'yo 7/25/2003 14:59'! nextCharFrom: sensor firstEvt: evtBuf | keyValue | keyValue := evtBuf third. ^ keyValue asCharacter. ! ! !NoNetworkError commentStamp: 'mir 5/12/2003 18:17' prior: 0! Signals that no network was found. This could happen, e.g., on dial-up connection when no connection was established when Squeak tried to access it. ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object ^object! ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object: anObject object _ anObject! ! !NonBooleanReceiver methodsFor: 'signaledException' stamp: 'hmm 7/29/2001 21:37'! isResumable ^true! ! !Notification methodsFor: 'exceptionDescription' stamp: 'pnm 8/16/2000 15:04'! defaultAction "No action is taken. The value nil is returned as the value of the message that signaled the exception." ^nil! ! !Number methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 21:00'! arg "Answer the argument of the receiver (see Complex | arg)." self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. 0 < self ifTrue: [^ 0] ifFalse: [^ Float pi]! ! !Number methodsFor: 'arithmetic' stamp: 'RAH 4/25/2000 19:49'! reciprocal "Answer 1 divided by the receiver. Create an error notification if the receiver is 0." #Numeric. "Changed 200/01/19 For ANSI <number> support." self = 0 ifTrue: [^ (ZeroDivide dividend: self) signal"<- Chg"]. ^ 1 / self! ! !Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'! degreeCos "Answer the cosine of the receiver taken as an angle in degrees." ^ (90 + self) degreeSin! ! !Number methodsFor: 'mathematical functions' stamp: 'sd 3/5/2004 10:04'! degreeSin "Answer the sine of the receiver taken as an angle in degrees." ^ self asFloat degreesToRadians sin! ! !Number methodsFor: 'mathematical functions' stamp: 'RAH 4/25/2000 19:49'! raisedToInteger: operand "Answer the receiver raised to the power operand, an Integer." | count result | #Numeric. "Changed 200/01/19 For ANSI <number> support." operand isInteger ifFalse: [^ ArithmeticError signal: 'parameter is not an Integer'"<- Chg"]. operand = 0 ifTrue: [^ self class one]. operand = 1 ifTrue: [^ self]. operand < 0 ifTrue: [^ (self raisedToInteger: operand negated) reciprocal]. count := 1. [(count := count + count) < operand] whileTrue. result := self class one. [count > 0] whileTrue: [result := result * result. (operand bitAnd: count) = 0 ifFalse: [result := result * self]. count := count bitShift: -1]. ^ result! ! !Number methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'! fractionPart "Answer the fractional part of the receiver." #Numeric. "2000/03/04 Harmon R. Added ANSI <number> protocol" ^ self - self truncated! ! !Number methodsFor: 'truncation and round off' stamp: 'RAH 4/25/2000 19:49'! integerPart "Answer the integer part of the receiver." #Numeric. "2000/03/04 Harmon R. Added ANSI <number> protocol" ^ self truncated! ! !Number methodsFor: 'testing' stamp: 'sw 9/27/2001 17:26'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Number! ! !Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! adaptToScaledDecimal: receiverScaledDecimal andSend: arithmeticOpSelector "Do any required conversion and then the arithmetic. receiverScaledDecimal arithmeticOpSelector self." #Numeric. "add 200/01/19 For ScaledDecimal support." ^ self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'ar 5/20/2001 01:40'! asB3DVector3 ^self@self@self! ! !Number methodsFor: 'converting' stamp: 'brp 5/13/2003 10:13'! asDuration ^ Duration nanoSeconds: self asInteger ! ! !Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! asFloatD "Answer a d precision floating-point number approximating the receiver." #Numeric. "add 200/01/19 For ANSI <number> protocol." ^ self asFloat! ! !Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! asFloatE "Answer a floating-point number approximating the receiver." #Numeric. "add 200/01/19 For ANSI <number> protocol." ^ self asFloat! ! !Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! asFloatQ "Answer a floating-point number approximating the receiver." #Numeric. "add 200/01/19 For ANSI <number> protocol." ^ self asFloat! ! !Number methodsFor: 'converting' stamp: 'dtl 9/25/2004 11:47'! asScaledDecimal "Answer a scaled decimal number approximating the receiver." #Numeric. ^ self asScaledDecimal: 8 ! ! !Number methodsFor: 'converting' stamp: 'RAH 4/25/2000 19:49'! asScaledDecimal: scale "Answer a scaled decimal number, with a fractional precision of scale, approximating the receiver." #Numeric. "add 200/01/19 For number protocol." ^ ScaledDecimal newFromNumber: self scale: scale! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:12'! day ^ self sign days! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! days ^ Duration days: self! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:28'! hour ^ self sign hours ! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! hours ^ Duration hours: self! ! !Number methodsFor: 'converting' stamp: 'mk 10/27/2003 18:17'! i ^ Complex real: 0 imaginary: self! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:26'! milliSecond ^ self sign milliSeconds ! ! !Number methodsFor: 'converting' stamp: 'brp 9/25/2003 13:16'! milliSeconds ^ Duration milliSeconds: self ! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:16'! minute ^ self sign minutes ! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:56'! minutes ^ Duration minutes: self! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:27'! nanoSecond ^ self sign nanoSeconds ! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 08:52'! nanoSeconds ^ Duration nanoSeconds: self.! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:17'! second ^ self sign seconds ! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'! seconds ^ Duration seconds: self! ! !Number methodsFor: 'converting' stamp: 'brp 5/21/2003 08:20'! sign: aNumber "Return a Number with the same sign as aNumber" ^ aNumber positive ifTrue: [self abs] ifFalse: [self abs negated].! ! !Number methodsFor: 'converting' stamp: 'brp 1/9/2004 06:19'! week ^ self sign weeks ! ! !Number methodsFor: 'converting' stamp: 'brp 5/16/2003 07:57'! weeks ^ Duration weeks: self! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:53'! printOn: aStream self printOn: aStream base: 10! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:55'! printOn: aStream base: base ^self subclassResponsibility! ! !Number methodsFor: 'printing' stamp: 'sw 9/13/2002 17:50'! printShowingDecimalPlaces: placesDesired "Print the receiver showing precisely the given number of places desired . If the placesDesired provided is positive, a decimal point and that many digits after the decimal point will always be shown. If the placesDesired is zero, a whole number will be shown, without a decimal point. This method could probably be greatly optimized -- improvements welcomed." | aString | placesDesired <= 0 ifTrue: [^ self rounded printString]. aString _ ((self asFloat roundTo: (Utilities floatPrecisionForDecimalPlaces: placesDesired)) asString), ((String new: placesDesired) atAllPut: $0). ^ aString copyFrom: 1 to: ((aString indexOf: $.) + placesDesired) " 23 printShowingDecimalPlaces: 2 23.5698 printShowingDecimalPlaces: 2 -234.567 printShowingDecimalPlaces: 5 23.4567 printShowingDecimalPlaces: 0 "! ! !Number methodsFor: 'printing' stamp: 'laza 3/30/2004 10:50'! printString ^self printStringBase: 10! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:50'! storeOn: aStream self printOn: aStream! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:59'! storeOn: aStream base: base self printOn: aStream base: base! ! !Number methodsFor: 'vocabulary' stamp: 'sw 8/3/2001 13:43'! vocabularyDemanded "Answer the vocabulary normally preferred by this object" ^ Vocabulary numberVocabulary! ! !Number commentStamp: '<historical>' prior: 0! Class Number holds the most general methods for dealing with numbers. Subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity. All of Number's subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If self<typeA> op: arg<typeB> fails because of incompatible types, then it is retried in the following guise: (arg adaptTypeA: self) op: arg adaptToTypeA. This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Squeak. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.! !Number class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 22:40'! readFrom: stringOrStream "Answer a number as described on aStream. The number may include a leading radix specification, as in 16rFADE" | value base aStream sign | aStream _ (stringOrStream isString) ifTrue: [ReadStream on: stringOrStream] ifFalse: [stringOrStream]. (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. base _ 10. value _ Integer readFrom: aStream base: base. (aStream peekFor: $r) ifTrue: ["<base>r<integer>" (base _ value) < 2 ifTrue: [^self error: 'Invalid radix']. (aStream peekFor: $-) ifTrue: [sign _ sign negated]. value _ Integer readFrom: aStream base: base]. ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! !Number class methodsFor: 'instance creation' stamp: 'yo 8/28/2002 22:41'! readFrom: stringOrStream base: base "Answer a number as described on aStream in the given number base." | aStream sign | aStream _ (stringOrStream isString) ifTrue: [ReadStream on: stringOrStream] ifFalse: [stringOrStream]. (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. ^ self readRemainderOf: (Integer readFrom: aStream base: base) from: aStream base: base withSign: sign! ! !Number class methodsFor: 'private' stamp: 'dtl 9/18/2004 18:20'! canParseAsScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream "Answer true if parsing a ScaleDecimal will succeed. Read from a copy of aStream to test the parsing." ^ aStream peek == $s and: [(self readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream copy) notNil]! ! !Number class methodsFor: 'private' stamp: 'dtl 11/24/2004 21:15'! canParseExponentFor: baseValue base: base from: aStream "Answer true if parsing the expoenent for a number will succeed. Read from a copy of aStream to test the parsing." ^ ('edq' includes: aStream peek) and: [(self readExponent: baseValue base: base from: aStream copy) notNil]! ! !Number class methodsFor: 'private' stamp: 'dtl 11/24/2004 21:16'! canParseExponentOrScaledDecimal: value integerPart: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream "Answer true if aStream contains parseable characters. The state of aStream is not changed." ^ (self canParseExponentFor: value base: base from: aStream) or: [self canParseAsScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream]! ! !Number class methodsFor: 'private' stamp: 'dtl 11/24/2004 21:14'! readExponent: baseValue base: base from: aStream "Complete creation of a number, reading exponent from aStream. Answer the number, or nil if parsing fails. <number>(e|d|q)<exponent>>" | sign exp value | aStream next. "skip e|d|q" sign _ ((aStream peek) == $-) ifTrue: [aStream next. -1] ifFalse: [1]. (aStream peek digitValue between: 0 and: 9) ifFalse: [^ nil]. "Avoid throwing an error" exp _ (Integer readFrom: aStream base: 10) * sign. value := baseValue * (base raisedTo: exp). ^ value ! ! !Number class methodsFor: 'private' stamp: 'dtl 11/24/2004 21:18'! readRemainderOf: integerPart from: aStream base: base withSign: sign "Read optional fractional part and exponent or decimal scale, and return the final result" "Changed 200/01/19 For ANSI Numeric Literals support." "Number readFrom: '3r-22.2'" | value fraction fractionDigits fracpos fractionPart scaledDecimal | #Numeric. value := integerPart. fractionDigits := 0. (aStream peekFor: $.) ifTrue: ["<integer>.<fraction>" (aStream atEnd not and: [aStream peek digitValue between: 0 and: base - 1]) ifTrue: [fracpos := aStream position. fractionPart := Integer readFrom: aStream base: base. fraction := fractionPart asFloat / (base raisedTo: aStream position - fracpos). fractionDigits := aStream position - fracpos. value := value asFloat + fraction] ifFalse: [(self canParseExponentOrScaledDecimal: value integerPart: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream) ifFalse: ["oops - just <integer>." aStream skip: -1. "un-gobble the period" ^ value * sign]]]. (self canParseAsScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream) ifTrue: ["<number>s[<scale>]" (scaledDecimal := self readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream) ifNotNil: [^ scaledDecimal]]. (self canParseExponentFor: value base: base from: aStream) ifTrue: ["<number>(e|d|q)<exponent>>" value := self readExponent: value base: base from: aStream]. (value isFloat and: [value = 0.0 and: [sign = -1]]) ifTrue: [^ Float negativeZero] ifFalse: [^ value * sign]! ! !Number class methodsFor: 'private' stamp: 'dtl 9/18/2004 19:07'! readScaledDecimal: integerPart fractionPart: fractionPart digits: fractionDigits base: base sign: sign from: aStream "Complete creation of a ScaledDecimal, reading scale from aStream. Answer a ScaledDecimal, or nil if parsing fails. <number>s[<scale>]" | scale decimalMultiplier decimalFraction | aStream atEnd ifTrue: [^ nil]. (aStream next == $s) ifFalse: [^ nil]. "<number>s<scale>" (aStream peek digitValue between: 0 and: 10) ifTrue: [scale := Integer readFrom: aStream] ifFalse: [^ nil]. scale isNil ifTrue: ["<number>s" fractionDigits = 0 ifTrue: ["<integer>s" scale := 0] ifFalse: ["<integer>.<fraction>s" scale := fractionDigits]]. fractionPart isNil ifTrue: [^ ScaledDecimal newFromNumber: integerPart * sign scale: scale] ifFalse: [decimalMultiplier := base raisedTo: fractionDigits. decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier. ^ ScaledDecimal newFromNumber: decimalFraction scale: scale]! ! !NumberParsingTest methodsFor: 'testing-Integer' stamp: 'dtl 11/24/2004 14:05'! testIntegerFromString "This covers parsing in Number>>readFrom: Trailing decimal points should be ignored." self assert: ('123' asNumber == 123). self assert: ('-123' asNumber == -123). self assert: ('123.' asNumber == 123). self assert: ('-123.' asNumber == -123). self assert: ('123This is not to be read' asNumber == 123). self assert: ('123s could be confused with a ScaledDecimal' asNumber == 123). self assert: ('123e could be confused with a Float' asNumber == 123). ! ! !NumberParsingTest methodsFor: 'testing-Integer' stamp: 'dtl 11/24/2004 14:04'! testIntegerReadFrom "Ensure remaining characters in a stream are not lost when parsing an integer." | rs i s | rs _ ReadStream on: '123s could be confused with a ScaledDecimal'. i _ Number readFrom: rs. self assert: i == 123. s _ rs upToEnd. self assert: 's could be confused with a ScaledDecimal' = s. rs _ ReadStream on: '123.s could be confused with a ScaledDecimal'. i _ Number readFrom: rs. self assert: i == 123. s _ rs upToEnd. self assert: '.s could be confused with a ScaledDecimal' = s ! ! !NumberParsingTest methodsFor: 'testing-Integer' stamp: 'dtl 11/24/2004 18:18'! testIntegerReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | aNumber rs | aNumber _ '2r1e26' asNumber. self assert: 67108864 = aNumber. self assert: (Number readFrom: '2r1e26') = (2 raisedTo: 26). rs _ '2r1e26eee' readStream. self assert: (Number readFrom: rs) = 67108864. self assert: rs upToEnd = 'eee' ! ! !NumberParsingTest methodsFor: 'testing-Float' stamp: 'dtl 11/24/2004 14:29'! testFloatFromStreamAsNumber "This covers parsing in Number>>readFrom:" | rs aFloat | rs _ '10r-12.3456' readStream. aFloat _ Number readFrom: rs. self assert: -12.3456 = aFloat. self assert: rs atEnd. rs _ '10r-12.3456e2' readStream. aFloat _ Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs _ '10r-12.3456e2e2' readStream. aFloat _ Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs upToEnd = 'e2'. rs _ '10r-12.3456d2' readStream. aFloat _ Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs _ '10r-12.3456q2' readStream. aFloat _ Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs _ '-12.3456q2' readStream. aFloat _ Number readFrom: rs. self assert: -1234.56 = aFloat. self assert: rs atEnd. rs _ '12.3456q2' readStream. aFloat _ Number readFrom: rs. self assert: 1234.56 = aFloat. self assert: rs atEnd. rs _ '12.3456z2' readStream. aFloat _ Number readFrom: rs. self assert: 12.3456 = aFloat. self assert: rs upToEnd = 'z2'. ! ! !NumberParsingTest methodsFor: 'testing-Float' stamp: 'dtl 11/24/2004 14:37'! testFloatFromStreamWithExponent "This covers parsing in Number>>readFrom:" | rs aFloat | rs _ '1.0e-14' readStream. aFloat _ Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs atEnd. rs _ '1.0e-14 1' readStream. aFloat _ Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = ' 1'. rs _ '1.0e-14eee' readStream. aFloat _ Number readFrom: rs. self assert: 1.0e-14 = aFloat. self assert: rs upToEnd = 'eee'. rs _ '1.0e14e10' readStream. aFloat _ Number readFrom: rs. self assert: 1.0e14 = aFloat. self assert: rs upToEnd = 'e10'. rs _ '1.0e+14e' readStream. "Plus sign is not parseable" aFloat _ Number readFrom: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e+14e'. ! ! !NumberParsingTest methodsFor: 'testing-Float' stamp: 'dtl 11/24/2004 14:07'! testFloatFromStringAsNumber "This covers parsing in Number>>readFrom:" | aFloat | aFloat _ '10r-12.3456' asNumber. self assert: -12.3456 = aFloat. aFloat _ '10r-12.3456e2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '10r-12.3456d2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '10r-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '-12.3456q2' asNumber. self assert: -1234.56 = aFloat. aFloat _ '12.3456q2' asNumber. self assert: 1234.56 = aFloat. ! ! !NumberParsingTest methodsFor: 'testing-Float' stamp: 'dtl 11/24/2004 14:12'! testFloatFromStringWithExponent "This covers parsing in Number>>readFrom:" | aFloat | aFloat _ '1.0e-14' asNumber. self assert: 1.0e-14 = aFloat. aFloat _ '1.0e-14 1' asNumber. self assert: 1.0e-14 = aFloat. aFloat _ '1.0e-14e' asNumber. self assert: 1.0e-14 = aFloat. aFloat _ '1.0e14e' asNumber. self assert: 1.0e14 = aFloat. aFloat _ '1.0e+14e' asNumber. "Plus sign is not parseable" self assert: 1.0 = aFloat. ! ! !NumberParsingTest methodsFor: 'testing-Float' stamp: 'dtl 11/24/2004 18:16'! testFloatReadWithRadix "This covers parsing in Number>>readFrom: Note: In most Smalltalk dialects, the radix notation is not used for numbers with exponents. In Squeak, a string with radix and exponent can be parsed, and the exponent is always treated as base 10 (not the base indicated in the radix prefix). I am not sure if this is a feature, a bug, or both, but the Squeak behavior is documented in this test. -dtl" | aNumber rs | aNumber _ '2r1.0101e9' asNumber. self assert: 672.0 = aNumber. self assert: (Number readFrom: '2r1.0101e9') = (1.3125 * (2 raisedTo: 9)). rs _ ReadStream on: '2r1.0101e9e9'. self assert: (Number readFrom: rs) = 672.0. self assert: rs upToEnd = 'e9' ! ! !NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0! Tests to verify parsing of numbers from streams and strings. Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.! !NumberTest methodsFor: 'as yet unclassified' stamp: 'md 10/18/2004 18:08'! testReadFrom self assert: 1.0e-14 = (Number readFrom: '1.0e-14'). self assert: 2r1e26 = (Number readFrom: '2r1e26').! ! !NumberType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:30'! addExtraItemsToMenu: aMenu forSlotSymbol: slotSym "If the receiver has extra menu items to add to the slot menu, here is its chance to do it. The defaultTarget of the menu is the player concerned." aMenu add: 'decimal places...' translated selector: #setPrecisionFor: argument: slotSym. aMenu balloonTextForLastItem: 'Lets you choose how many decimal places should be shown in readouts for this variable' translated! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/15/2002 16:50'! addUserSlotItemsTo: aMenu slotSymbol: slotSym "Optionally add items to the menu that pertain to a user-defined slot of the given symbol" "aMenu add: 'decimal places...' selector: #setPrecisionFor: argument: slotSym NB: This item is now generically added for system as well as user slots, so the addition is now done in NubmerType.addExtraItemsToMenu:forSlotSymbol:"! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/27/2001 02:53'! comparatorForSampleBoolean "Answer the comparator to use in tile coercions involving the receiver; normally, the equality comparator is used but NumberType overrides" ^ #<! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ 5 newTileMorphRepresentative typeColor: self typeColor! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:37'! newReadoutTile "Answer a tile that can serve as a readout for data of this type" ^ NumericReadoutTile new typeColor: Color lightGray lighter! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:11'! wantsAssignmentTileVariants "Answer whether an assignment tile for a variable of this type should show variants to increase-by, decrease-by, multiply-by." ^ true! ! !NumberType methodsFor: 'tiles' stamp: 'sw 9/26/2001 03:18'! wantsSuffixArrow "Answer whether a tile showing data of this type would like to have a suffix arrow" ^ true! ! !NumberType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ (1 to: 9) atRandom! ! !NumberType methodsFor: 'initialization' stamp: 'sw 10/10/2001 06:24'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" | aMethodCategory aMethodInterface | super initialize. "Vocabulary replaceNumberVocabulary" "Vocabulary addVocabulary: Vocabulary newNumberVocabulary" self vocabularyName: #Number. self documentation: 'Numbers are things that can do arithmetic, have their magnitudes compared, etc.'. #((comparing 'Determining which of two numbers is larger' (= < > <= >= ~= ~~)) (arithmetic 'Basic numeric operation' (* + - / // \\ abs negated quo: rem:)) (testing 'Testing a number' (even isDivisibleBy: negative odd positive sign)) (#'mathematical functions' 'Trigonometric and exponential functions' (cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:)) (converting 'Converting a number to another form' (@ asInteger asPoint degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees)) (#'truncation and round off' 'Making a real number (with a decimal point) into an integer' (ceiling floor roundTo: roundUpTo: rounded truncateTo: truncated)) ) do: [:item | aMethodCategory _ ElementCategory new categoryName: item first. aMethodCategory documentation: item second. item third do: [:aSelector | aMethodInterface _ MethodInterface new conjuredUpFor: aSelector class: (Number whichClassIncludesSelector: aSelector). aMethodInterface argumentVariables do: [:var | var variableType: #Number]. (#(* + - / // \\ abs negated quo: rem: cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger: asInteger degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees) includes: aSelector) ifTrue: [aMethodInterface resultType: #Number]. (#( @ asPoint ) includes: aSelector) ifTrue: [aMethodInterface resultType: #Point]. (#(= < > <= >= ~= ~~ even isDivisibleBy: negative odd positive) includes: aSelector) ifTrue: [aMethodInterface resultType: #Boolean]. aMethodInterface setNotToRefresh. self atKey: aSelector putMethodInterface: aMethodInterface. aMethodCategory elementAt: aSelector put: aMethodInterface]. self addCategory: aMethodCategory]. " (('truncation and round off' ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated) ('testing' basicType even isDivisibleBy: isInf isInfinite isNaN isNumber isZero negative odd positive sign strictlyPositive) ('converting' @ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees) ('intervals' to: to:by: to:by:do: to:do:) ('printing' defaultLabelForInspector isOrAreStringWith: newTileMorphRepresentative printOn: printStringBase: storeOn: storeOn:base: storeStringBase: stringForReadout) ('comparing' closeTo:) ('filter streaming' byteEncode:) ('as yet unclassified' reduce)" ! ! !NumberType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(0.8 0.4 0.2)! ! !NumberType commentStamp: 'sw 10/3/2002 02:18' prior: 0! NumberType is a data type representing a numeric value.! !NumericReadoutTile methodsFor: 'accessing' stamp: 'tak 12/5/2004 15:13'! literal: anObject literal _ anObject. self updateLiteralLabel. submorphs last informTarget! ! !NumericReadoutTile methodsFor: 'accessing' stamp: 'tak 12/6/2004 01:53'! literalFromContents | label | label _ self labelMorph ifNil: [^ super literal]. label step. ^ literal _ label valueFromContents! ! !NumericReadoutTile methodsFor: 'parts bin' stamp: 'sw 11/15/2001 20:22'! initializeToStandAlone "Enclose my prototype in a SyntaxMorph. For the ObjectTool" | aWatcher aTile aLine aColor ms slotMsg | super initializeToStandAlone. aColor _ Color r: 0.387 g: 0.581 b: 1.0. aTile _ self typeColor: aColor. aWatcher _ UpdatingStringMorph new. aWatcher growable: true; getSelector: nil; putSelector: nil; setToAllowTextEdit. aWatcher target: nil. aTile addMorphBack: aWatcher. aTile addArrows. aTile setLiteralTo: 5 width: 30. ms _ MessageSend receiver: nil selector: #aNumber arguments: #(). slotMsg _ ms asTilesIn: Player globalNames: false. "For CardPlayers, use 'aPlayer'. For others, name it, and use its name." ms _ MessageSend receiver: 3 selector: #= asSymbol arguments: #(5). aLine _ ms asTilesIn: Player globalNames: false. aLine firstSubmorph delete. "A little over-complicated? Yes?" aLine addMorphFront: (slotMsg submorphs second) firstSubmorph. aLine addMorphFront: (Morph new transparentSpacerOfSize: 3@3). aLine lastSubmorph delete. aLine lastSubmorph delete. aLine color: aColor. aLine addMorphBack: (Morph new transparentSpacerOfSize: 3@3). aLine addMorphBack: aTile. aLine cellPositioning: #leftCenter. aWatcher step; fitContents. ^ aLine markAsPartsDonor.! ! !NumericReadoutTile methodsFor: 'testing' stamp: 'tk 11/1/2001 12:41'! basicType "Answer a symbol representing the inherent type I hold" "Number String Boolean player collection sound color etc" ^ #Number! ! !NumericReadoutTile class methodsFor: 'instance creation' stamp: 'tk 12/14/2001 19:32'! borderedPrototype "Just number and up/down arrows" | aWatcher aTile | aTile _ self new typeColor: (Color r: 0.387 g: 0.581 b: 1.0). aWatcher _ UpdatingStringMorph new. aWatcher growable: true; setNameTo: 'value'. aTile addMorphBack: aWatcher. aTile addArrows; setNameTo: 'Number (mid)'. aTile setLiteralTo: 5 width: 30. aWatcher step; fitContents; setToAllowTextEdit. ^ aTile extent: 30@24; markAsPartsDonor! ! !NumericReadoutTile class methodsFor: 'instance creation' stamp: 'tk 12/14/2001 19:29'! simplePrototype "Bare number readout. Will keep up to data with a number once it has target, getterSelector, setterSelector." ^ (UpdatingStringMorph new) contents: '5'; growable: true; setToAllowTextEdit; step; fitContents; setNameTo: 'Number (bare)'; markAsPartsDonor! ! !NumericReadoutTile class methodsFor: 'instance creation' stamp: 'nk 8/23/2004 18:11'! supplementaryPartsDescriptions "Answer additional items for the parts bin" Preferences universalTiles ifFalse: [^ #()]. ^ {DescriptionForPartsBin formalName: 'Number (fancy)' categoryList: #('Basic') documentation: 'A number readout for a Stack. Shows current value. Click and type the value. Shift-click on title to edit.' globalReceiverSymbol: #NumericReadoutTile nativitySelector: #authoringPrototype. DescriptionForPartsBin formalName: 'Number (bare)' categoryList: #('Basic') documentation: 'A number readout for a Stack. Shows current value. Click and type the value.' globalReceiverSymbol: #NumericReadoutTile nativitySelector: #simplePrototype. DescriptionForPartsBin formalName: 'Number (mid)' categoryList: #('Basic') documentation: 'A number readout for a Stack. Shows current value. Click and type the value.' globalReceiverSymbol: #NumericReadoutTile nativitySelector: #borderedPrototype}! ! !NumericReadoutTile class methodsFor: 'scripting' stamp: 'tk 12/14/2001 19:30'! authoringPrototype "Enclose my prototype in a SyntaxMorph." | aWatcher aTile aLine aColor ms slotMsg | aColor _ Color r: 0.387 g: 0.581 b: 1.0. aTile _ self new typeColor: aColor. aWatcher _ UpdatingStringMorph new. aWatcher growable: true; setToAllowTextEdit; getSelector: nil; putSelector: nil. aWatcher target: nil. aTile addMorphBack: aWatcher. aTile addArrows. aTile setLiteralTo: 5 width: 30. "This is the long way around to do this..." ms _ MessageSend receiver: nil selector: #aNumber arguments: #(). slotMsg _ ms asTilesIn: Player globalNames: false. "For CardPlayers, use 'aPlayer'. For others, name it, and use its name." ms _ MessageSend receiver: 3 selector: #= asSymbol arguments: #(5). aLine _ ms asTilesIn: Player globalNames: false. aLine firstSubmorph delete. aLine addMorphFront: (slotMsg submorphs second) firstSubmorph. aLine firstSubmorph setNameTo: 'label'. aLine addMorphFront: (Morph new transparentSpacerOfSize: 3@3). aLine lastSubmorph delete. aLine lastSubmorph delete. aLine color: aColor; setNameTo: 'Number (fancy)'. aLine addMorphBack: (Morph new transparentSpacerOfSize: 3@3). aLine addMorphBack: aTile. aLine readOut setNameTo: 'value'. aLine cellPositioning: #leftCenter. aWatcher step; fitContents. ^ aLine markAsPartsDonor.! ! !Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'! sunitAddDependent: anObject self addDependent: anObject! ! !Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'! sunitChanged: anAspect self changed: anAspect! ! !Object methodsFor: '*sunit-preload' stamp: 'jp 3/17/2003 09:58'! sunitRemoveDependent: anObject self removeDependent: anObject! ! !Object methodsFor: '*system-support' stamp: 'dvf 8/23/2003 12:27'! systemNavigation ^ SystemNavigation default! ! !Object methodsFor: '*tools-browser' stamp: 'mu 3/6/2004 15:13'! browse self systemNavigation browseClass: self class! ! !Object methodsFor: '*tools-browser' stamp: 'mu 3/11/2004 16:00'! browseHierarchy self systemNavigation browseHierarchy: self class! ! !Object methodsFor: 'Breakpoint' stamp: 'bkv 7/1/2003 12:33'! break "This is a simple message to use for inserting breakpoints during debugging. The debugger is opened by sending a signal. This gives a chance to restore invariants related to multiple processes." BreakPoint signal. "nil break."! ! !Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 11:39'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." <primitive: 60> index isInteger ifTrue: [self class isVariable ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'accessing' stamp: 'yo 6/29/2004 13:08'! at: index put: value "Primitive. Assumes receiver is indexable. Store the argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." <primitive: 61> index isInteger ifTrue: [self class isVariable ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]] ifFalse: [self errorNotIndexable]]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'accessing' stamp: 'md 12/12/2003 16:25'! doIfNotNil: aBlock self deprecated: 'use ifNotNilDo:'. ^ self ifNotNilDo: aBlock ! ! !Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'! ifNil: nilBlock ifNotNilDo: aBlock "Evaluate aBlock with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'! ifNotNilDo: aBlock ifNil: nilBlock "Evaluate aBlock with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59'! in: aBlock "Evaluate the given block with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'class membership' stamp: 'sw 9/27/2001 15:51'! inheritsFromAnyIn: aList "Answer whether the receiver inherits from any class represented by any element in the list. The elements of the list can be classes, class name symbols, or strings representing possible class names. This allows speculative membership tests to be made even when some of the classes may not be known to the current image, and even when their names are not interned symbols." | aClass | aList do: [:elem | Symbol hasInterned: elem asString ifTrue: [:elemSymbol | (((aClass _ Smalltalk at: elemSymbol ifAbsent: [nil]) isKindOf: Class) and: [self isKindOf: aClass]) ifTrue: [^ true]]]. ^ false " {3. true. 'olive'} do: [:token | {{#Number. #Boolean}. {Number. Boolean }. {'Number'. 'Boolean'}} do: [:list | Transcript cr; show: token asString, ' list element provided as a ', list first class name, ' - ', (token inheritsFromAnyIn: list) asString]] "! ! !Object methodsFor: 'comparing' stamp: 'ajh 2/2/2002 15:02'! literalEqual: other ^ self class == other class and: [self = other]! ! !Object methodsFor: 'converting' stamp: 'rw 4/27/2002 07:48'! asActionSequence ^WeakActionSequence with: self! ! !Object methodsFor: 'converting' stamp: 'rw 7/20/2003 16:03'! asActionSequenceTrappingErrors ^WeakActionSequenceTrappingErrors with: self! ! !Object methodsFor: 'converting' stamp: 'ajh 3/11/2003 10:27'! asStringOrText "Answer a string that represents the receiver." ^ self printString ! ! !Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:37'! mustBeBoolean "Catches attempts to test truth of non-Booleans. This message is sent from the VM. The sending context is rewound to just before the jump causing this exception." ^ self mustBeBooleanIn: thisContext sender! ! !Object methodsFor: 'converting' stamp: 'ajh 7/6/2003 20:40'! mustBeBooleanIn: context "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." | proceedValue | context skipBackBeforeJump. proceedValue _ NonBooleanReceiver new object: self; signal: 'proceed for truth.'. ^ proceedValue ~~ false! ! !Object methodsFor: 'converting' stamp: 'sw 3/26/2001 12:12'! printDirectlyToDisplay "For debugging: write the receiver's printString directly to the display at (0, 100); senders of this are detected by the check-for-slips mechanism." self asString displayAt: 0@100 "StringMorph someInstance printDirectlyToDisplay"! ! !Object methodsFor: 'copying' stamp: 'ajh 8/18/2001 21:25'! copy "Answer another instance just like the receiver. Subclasses typically override postCopy; they typically do not override shallowCopy." ^self shallowCopy postCopy! ! !Object methodsFor: 'copying' stamp: 'tpr 2/14/2004 21:53'! copyFrom: anotherObject "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " | mine his | <primitive: 168> mine _ self class allInstVarNames. his _ anotherObject class allInstVarNames. 1 to: (mine size min: his size) do: [:ind | (mine at: ind) = (his at: ind) ifTrue: [ self instVarAt: ind put: (anotherObject instVarAt: ind)]]. self class isVariable & anotherObject class isVariable ifTrue: [ 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | self basicAt: ind put: (anotherObject basicAt: ind)]].! ! !Object methodsFor: 'copying' stamp: 'ajh 5/23/2002 00:38'! copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars match | myInstVars _ self class allInstVarNames. otherInstVars _ otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | (match _ otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. ! ! !Object methodsFor: 'copying' stamp: 'ajh 1/27/2003 18:45'! postCopy "self is a shallow copy, subclasses should copy fields as necessary to complete the full copy" ^ self! ! !Object methodsFor: 'copying' stamp: 'tk 3/11/2003 13:58'! veryDeepCopy "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy." | copier new | copier _ DeepCopier new initialize: self initialDeepCopierSize. new _ self veryDeepCopyWith: copier. copier mapUniClasses. copier references associationsDo: [:assoc | assoc value veryDeepFixupWith: copier]. copier fixDependents. ^ new! ! !Object methodsFor: 'copying' stamp: 'tk 3/11/2003 13:58'! veryDeepCopySibling "Do a complete tree copy using a dictionary. Substitute a clone of oldPlayer for the root. Normally, a Player or non systemDefined object would have a new class. We do not want one this time. An object in the tree twice, is only copied once. All references to the object in the copy of the tree will point to the new copy." | copier new | copier _ DeepCopier new initialize: self initialDeepCopierSize. copier newUniClasses: false. new _ self veryDeepCopyWith: copier. copier mapUniClasses. copier references associationsDo: [:assoc | assoc value veryDeepFixupWith: copier]. copier fixDependents. ^ new! ! !Object methodsFor: 'copying' stamp: 'tk 5/13/2003 19:39'! veryDeepCopyUsing: copier "Do a complete tree copy using a dictionary. An object in the tree twice is only copied once. All references to the object in the copy of the tree will point to the new copy. Same as veryDeepCopy except copier (with dictionary) is supplied. ** do not delete this method, even if it has no callers **" | new refs newDep newModel | new _ self veryDeepCopyWith: copier. copier mapUniClasses. copier references associationsDo: [:assoc | assoc value veryDeepFixupWith: copier]. "Fix dependents" refs _ copier references. DependentsFields associationsDo: [:pair | pair value do: [:dep | (newDep _ refs at: dep ifAbsent: [nil]) ifNotNil: [ newModel _ refs at: pair key ifAbsent: [pair key]. newModel addDependent: newDep]]]. ^ new! ! !Object methodsFor: 'copying' stamp: 'tk 3/11/2003 14:12'! veryDeepCopyWith: deepCopier "Copy me and the entire tree of objects I point to. An object in the tree twice is copied once, and both references point to him. deepCopier holds a dictionary of objects we have seen. Some classes refuse to be copied. Some classes are picky about which fields get deep copied." | class index sub subAss new uc sup has mine | deepCopier references at: self ifPresent: [:newer | ^ newer]. "already did him" class _ self class. class isMeta ifTrue: [^ self]. "a class" new _ self clone. (class isSystemDefined not and: [deepCopier newUniClasses "allowed"]) ifTrue: [ uc _ deepCopier uniClasses at: class ifAbsent: [nil]. uc ifNil: [ deepCopier uniClasses at: class put: (uc _ self copyUniClassWith: deepCopier). deepCopier references at: class put: uc]. "remember" new _ uc new. new copyFrom: self]. "copy inst vars in case any are weak" deepCopier references at: self put: new. "remember" (class isVariable and: [class isPointers]) ifTrue: [index _ self basicSize. [index > 0] whileTrue: [sub _ self basicAt: index. (subAss _ deepCopier references associationAt: sub ifAbsent: [nil]) ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)] ifNotNil: [new basicAt: index put: subAss value]. index _ index - 1]]. "Ask each superclass if it wants to share (weak copy) any inst vars" new veryDeepInner: deepCopier. "does super a lot" "other superclasses want all inst vars deep copied" sup _ class. index _ class instSize. [has _ sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil]. has _ has ifNil: [class isSystemDefined not "is a uniClass"] ifNotNil: [true]. mine _ sup instVarNames. has ifTrue: [index _ index - mine size] "skip inst vars" ifFalse: [1 to: mine size do: [:xx | sub _ self instVarAt: index. (subAss _ deepCopier references associationAt: sub ifAbsent: [nil]) "use association, not value, so nil is an exceptional value" ifNil: [new instVarAt: index put: (sub veryDeepCopyWith: deepCopier)] ifNotNil: [new instVarAt: index put: subAss value]. index _ index - 1]]. (sup _ sup superclass) == nil] whileFalse. new rehash. "force Sets and Dictionaries to rehash" ^ new ! ! !Object methodsFor: 'copying' stamp: 'tk 9/4/2001 10:30'! veryDeepInner: deepCopier "No special treatment for inst vars of my superclasses. Override when some need to be weakly copied. Object>>veryDeepCopyWith: will veryDeepCopy any inst var whose class does not actually define veryDeepInner:" ! ! !Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:33'! asMorph "Open a morph, as best one can, on the receiver" ^ self asStringMorph " 234 asMorph (ScriptingSystem formAtKey: #TinyMenu) asMorph 'fred' asMorph " ! ! !Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'! asStringMorph "Open a StringMorph, as best one can, on the receiver" ^ self asStringOrText asStringMorph ! ! !Object methodsFor: 'creation' stamp: 'nk 2/26/2004 13:35'! asTextMorph "Open a TextMorph, as best one can, on the receiver" ^ TextMorph new contentsAsIs: self asStringOrText ! ! !Object methodsFor: 'creation' stamp: 'sw 1/29/2002 21:45'! openAsMorph "Open a morph, as best one can, on the receiver" ^ self asMorph openInHand " 234 openAsMorph (ScriptingSystem formAtKey: #TinyMenu) openAsMorph 'fred' openAsMorph "! ! !Object methodsFor: 'dependents access' stamp: 'ar 2/11/2001 01:55'! addDependent: anObject "Make the given object one of the receiver's dependents." | dependents | dependents _ self dependents. (dependents includes: anObject) ifFalse: [self myDependents: (dependents copyWithDependent: anObject)]. ^ anObject! ! !Object methodsFor: 'dependents access' stamp: 'reThink 2/18/2001 17:06'! release "Remove references to objects that may refer to the receiver. This message should be overridden by subclasses with any cycles, in which case the subclass should also include the expression super release." self releaseActionMap! ! !Object methodsFor: 'deprecated' stamp: 'md 12/12/2003 17:02'! beep: soundName "Make the given sound, unless the making of sound is disabled in Preferences." self deprecated: 'Use SampledSound>>playSoundNamed: instead.'. Preferences soundsEnabled ifTrue: [self playSoundNamed: soundName] ! ! !Object methodsFor: 'deprecated' stamp: 'gk 2/24/2004 08:50'! beepPrimitive "Deprecated. Beep in the absence of sound support." self deprecated: 'Use Beeper class>>beep or Beeper class>>beepPrimitive instead.'. Beeper beepPrimitive! ! !Object methodsFor: 'drag and drop' stamp: 'bh 9/16/2001 18:10'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph ^false.! ! !Object methodsFor: 'debugging' stamp: 'md 11/24/2004 11:45'! haltIf: condition "This is the typical message to use for inserting breakpoints during debugging. Param can be a block or expression, halt if true. If the Block has one arg, the receiver is bound to that. If the condition is a selector, we look up in the callchain. Halt if any method's selector equals selector." | cntxt | condition isSymbol ifTrue:[ "only halt if a method with selector symbol is in callchain" cntxt := thisContext. [cntxt sender isNil] whileFalse: [ cntxt := cntxt sender. (cntxt selector = condition) ifTrue: [Halt signal]. ]. ^self. ]. (condition isBlock ifTrue: [condition valueWithPossibleArgument: self] ifFalse: [condition] ) ifTrue: [ Halt signal ].! ! !Object methodsFor: 'error handling' stamp: 'md 10/13/2004 15:59'! backwardCompatibilityOnly: anExplanationString "Warn that the sending method has been deprecated. Methods that are tagt with #backwardCompatibility: are kept for compatibility." Preferences showDeprecationWarnings ifTrue: [Deprecation signal: thisContext sender printString, ' has been deprecated (but will be kept for compatibility). ', anExplanationString]! ! !Object methodsFor: 'error handling' stamp: 'dew 10/6/2003 18:20'! deprecated: anExplanationString "Warn that the sending method has been deprecated." Preferences showDeprecationWarnings ifTrue: [Deprecation signal: thisContext sender printString, ' has been deprecated. ', anExplanationString]! ! !Object methodsFor: 'error handling' stamp: 'dew 10/7/2003 00:26'! deprecated: anExplanationString block: aBlock "Warn that the sender has been deprecated. Answer the value of aBlock on resumption. (Note that #deprecated: is usually the preferred method.)" Preferences showDeprecationWarnings ifTrue: [Deprecation signal: thisContext sender printString, ' has been deprecated. ', anExplanationString]. ^ aBlock value. ! ! !Object methodsFor: 'error handling' stamp: 'sd 11/13/2003 21:11'! deprecated: aBlock explanation: aString "This method is OBSOLETE. Use #deprecated:block: instead." self deprecated: 'Use Object>>deprecated:block: instead of deprecated:explanation:.'. Preferences showDeprecationWarnings ifTrue: [Deprecation signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})]. ^ aBlock value. ! ! !Object methodsFor: 'error handling' stamp: 'sd 11/13/2003 21:10'! deprecatedExplanation: aString "This method is OBSOLETE. Use #deprecated: instead." self deprecated: 'Use Object>>deprecated: instead of deprecatedExplanation:.'. Preferences showDeprecationWarnings ifTrue: [Deprecation signal: ('{1} has been deprecated. {2}' translated format: {thisContext sender printString. aString})]! ! !Object methodsFor: 'error handling' stamp: 'nk 7/10/2004 09:43'! doesNotUnderstand: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but the receiver does not understand this message (typically sent from the machine when a message is sent to the receiver and no method is defined for that selector)." "Testing: (3 activeProcess)" (Preferences autoAccessors and: [self tryToDefineVariableAccess: aMessage]) ifTrue: [^ aMessage sentTo: self]. MessageNotUnderstood new message: aMessage; receiver: self; signal. ^ aMessage sentTo: self. ! ! !Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:47'! dpsTrace: reportObject Transcript myDependents isNil ifTrue: [^self]. self dpsTrace: reportObject levels: 1 withContext: thisContext " nil dpsTrace: 'sludder'. "! ! !Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:49'! dpsTrace: reportObject levels: anInt self dpsTrace: reportObject levels: anInt withContext: thisContext "(1 to: 3) do: [:int | nil dpsTrace: int levels: 5.]"! ! !Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 17:02'! dpsTrace: reportObject levels: anInt withContext: currentContext | reportString context displayCount | reportString := (reportObject respondsTo: #asString) ifTrue: [reportObject asString] ifFalse: [reportObject printString]. (Smalltalk at: #Decompiler ifAbsent: [nil]) ifNil: [Transcript cr; show: reportString] ifNotNil: [context := currentContext. displayCount := anInt > 1. 1 to: anInt do: [:count | Transcript cr. displayCount ifTrue: [Transcript show: count printString, ': ']. reportString notNil ifTrue: [Transcript show: context home class name , '/' , context sender selector, ' (' , reportString , ')'. context := context sender. reportString := nil] ifFalse: [(context notNil and: [(context := context sender) notNil]) ifTrue: [Transcript show: context receiver class name , '/' , context selector]]]. "Transcript cr"].! ! !Object methodsFor: 'error handling' stamp: 'ar 2/13/2001 20:49'! externalCallFailed "A call to an external function has failed." ^(Smalltalk at: #ExternalFunction ifAbsent:[^self error: 'FFI not installed']) externalCallFailed! ! !Object methodsFor: 'error handling' stamp: 'hg 10/2/2001 20:49'! notify: aString "Create and schedule a Notifier with the argument as the message in order to request confirmation before a process can proceed." Warning signal: aString "nil notify: 'confirmation message'"! ! !Object methodsFor: 'error handling' stamp: 'sw 5/23/2001 13:43'! notifyWithLabel: aString "Create and schedule a Notifier with aString as the window label as well as the contents of the window, in order to request confirmation before a process can proceed." Debugger openContext: thisContext label: aString contents: aString "nil notifyWithLabel: 'let us see if this works'"! ! !Object methodsFor: 'error handling' stamp: 'AFi 2/8/2003 22:52'! shouldBeImplemented "Announce that this message should be implemented" self error: 'This message should be implemented'! ! !Object methodsFor: 'error handling' stamp: 'ajh 9/7/2002 21:20'! subclassResponsibility "This message sets up a framework for the behavior of the class' subclasses. Announce that the subclass should have implemented this message." self error: 'My subclass should have overridden ', thisContext sender methodSelector printString! ! !Object methodsFor: 'error handling' stamp: 'tk 6/18/2001 15:04'! tryToDefineVariableAccess: aMessage "See if the message just wants to get at an instance variable of this class. Ask the user if its OK. If so, define the message to read or write that instance or class variable and retry." | ask newMessage sel canDo classOrSuper | aMessage arguments size > 1 ifTrue: [^ false]. sel _ aMessage selector asString. "works for 0 args" aMessage arguments size = 1 ifTrue: [ sel last = $: ifFalse: [^ false]. sel _ sel copyWithout: $:]. canDo _ false. classOrSuper _ self class. [((classOrSuper instVarNames includes: sel) ifTrue: [canDo _ true. nil] ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse. canDo ifFalse: [classOrSuper _ self class. [((classOrSuper classVarNames includes: sel) ifTrue: [canDo _ true. nil] ifFalse: [classOrSuper _ classOrSuper superclass]) == nil] whileFalse]. canDo ifFalse: [^ false]. ask _ self confirm: 'A ', thisContext sender sender receiver class printString, ' wants to ', (aMessage arguments size = 1 ifTrue: ['write into'] ifFalse: ['read from']), ' ', sel ,' in class ', classOrSuper printString, '. Define a this access message?'. ask ifTrue: [ aMessage arguments size = 1 ifTrue: [newMessage _ aMessage selector, ' anObject ', sel, ' _ anObject'] ifFalse: [newMessage _ aMessage selector, ' ^', aMessage selector]. classOrSuper compile: newMessage classified: 'accessing' notifying: nil]. ^ ask! ! !Object methodsFor: 'evaluating' stamp: 'reThink 3/12/2001 18:14'! value ^self! ! !Object methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 15:23'! valueWithArguments: aSequenceOfArguments ^self! ! !Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! actionForEvent: anEventSelector "Answer the action to be evaluated when <anEventSelector> has been triggered." | actions | actions := self actionMap at: anEventSelector asSymbol ifAbsent: [nil]. actions ifNil: [^nil]. ^ actions asMinimalRepresentation! ! !Object methodsFor: 'events-accessing' stamp: 'nk 12/20/2002 17:48'! actionForEvent: anEventSelector ifAbsent: anExceptionBlock "Answer the action to be evaluated when <anEventSelector> has been triggered." | actions | actions := self actionMap at: anEventSelector asSymbol ifAbsent: [nil]. actions ifNil: [^anExceptionBlock value]. ^ actions asMinimalRepresentation! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 14:43'! actionMap ^EventManager actionMapFor: self! ! !Object methodsFor: 'events-accessing' stamp: 'rw 4/27/2002 08:35'! actionSequenceForEvent: anEventSelector ^(self actionMap at: anEventSelector asSymbol ifAbsent: [^WeakActionSequence new]) asActionSequence! ! !Object methodsFor: 'events-accessing' stamp: 'SqR 6/28/2001 13:19'! actionsDo: aBlock self actionMap do: aBlock! ! !Object methodsFor: 'events-accessing' stamp: 'rw 2/10/2002 13:05'! createActionMap ^IdentityDictionary new! ! !Object methodsFor: 'events-accessing' stamp: 'SqR 2/19/2001 14:04'! hasActionForEvent: anEventSelector "Answer true if there is an action associated with anEventSelector" ^(self actionForEvent: anEventSelector) notNil! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/18/2001 15:29'! setActionSequence: actionSequence forEvent: anEventSelector | action | action := actionSequence asMinimalRepresentation. action == nil ifTrue: [self removeActionsForEvent: anEventSelector] ifFalse: [self updateableActionMap at: anEventSelector asSymbol put: action]! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/25/2001 08:50'! updateableActionMap ^EventManager updateableActionMapFor: self! ! !Object methodsFor: 'events-registering' stamp: 'reThink 2/18/2001 15:04'! when: anEventSelector evaluate: anAction | actions | actions := self actionSequenceForEvent: anEventSelector. (actions includes: anAction) ifTrue: [^ self]. self setActionSequence: (actions copyWith: anAction) forEvent: anEventSelector! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector)! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject with: anArg self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector arguments: (Array with: anArg))! ! !Object methodsFor: 'events-registering' stamp: 'rww 12/30/2002 10:37'! when: anEventSelector send: aMessageSelector to: anObject withArguments: anArgArray self when: anEventSelector evaluate: (WeakMessageSend receiver: anObject selector: aMessageSelector arguments: anArgArray)! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! releaseActionMap EventManager releaseActionMapFor: self! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! removeAction: anAction forEvent: anEventSelector self removeActionsSatisfying: [:action | action = anAction] forEvent: anEventSelector! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! removeActionsForEvent: anEventSelector | map | map := self actionMap. map removeKey: anEventSelector asSymbol ifAbsent: []. map isEmpty ifTrue: [self releaseActionMap]! ! !Object methodsFor: 'events-removing' stamp: 'nk 8/25/2003 21:46'! removeActionsSatisfying: aBlock self actionMap keys do: [:eachEventSelector | self removeActionsSatisfying: aBlock forEvent: eachEventSelector ]! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! removeActionsSatisfying: aOneArgBlock forEvent: anEventSelector self setActionSequence: ((self actionSequenceForEvent: anEventSelector) reject: [:anAction | aOneArgBlock value: anAction]) forEvent: anEventSelector! ! !Object methodsFor: 'events-removing' stamp: 'rw 7/29/2003 17:18'! removeActionsWithReceiver: anObject self actionMap copy keysDo: [:eachEventSelector | self removeActionsSatisfying: [:anAction | anAction receiver == anObject] forEvent: eachEventSelector ]! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:36'! removeActionsWithReceiver: anObject forEvent: anEventSelector self removeActionsSatisfying: [:anAction | anAction receiver == anObject] forEvent: anEventSelector! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:22'! triggerEvent: anEventSelector "Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action." ^(self actionForEvent: anEventSelector) value! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 17:09'! triggerEvent: anEventSelector ifNotHandled: anExceptionBlock "Evaluate all actions registered for <anEventSelector>. Return the value of the last registered action." ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) value ! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! triggerEvent: anEventSelector with: anObject ^self triggerEvent: anEventSelector withArguments: (Array with: anObject)! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! triggerEvent: anEventSelector with: anObject ifNotHandled: anExceptionBlock ^self triggerEvent: anEventSelector withArguments: (Array with: anObject) ifNotHandled: anExceptionBlock! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! triggerEvent: anEventSelector withArguments: anArgumentList ^(self actionForEvent: anEventSelector) valueWithArguments: anArgumentList! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! triggerEvent: anEventSelector withArguments: anArgumentList ifNotHandled: anExceptionBlock ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) valueWithArguments: anArgumentList! ! !Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:10'! finalizationRegistry "Answer the finalization registry associated with the receiver." ^WeakRegistry default! ! !Object methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:14'! toFinalizeSend: aSelector to: aFinalizer with: aResourceHandle "When I am finalized (e.g., garbage collected) close the associated resource handle by sending aSelector to the appropriate finalizer (the guy who knows how to get rid of the resource). WARNING: Neither the finalizer nor the resource handle are allowed to reference me. If they do, then I will NEVER be garbage collected. Since this cannot be validated here, it is up to the client to make sure this invariant is not broken." self == aFinalizer ifTrue:[self error: 'I cannot finalize myself']. self == aResourceHandle ifTrue:[self error: 'I cannot finalize myself']. ^self finalizationRegistry add: self executor: (ObjectFinalizer new receiver: aFinalizer selector: aSelector argument: aResourceHandle)! ! !Object methodsFor: 'graph model' stamp: 'dgd 8/26/2004 14:58'! addModelYellowButtonMenuItemsTo: aCustomMenu forMorph: aMorph hand: aHandMorph "The receiver serves as the model for aMorph; a menu is being constructed for the morph, and here the receiver is able to add its own items" Preferences cmdGesturesEnabled ifTrue: [ "build mode" aCustomMenu add: 'inspect model' translated target: self action: #inspect. ]. ^aCustomMenu ! ! !Object methodsFor: 'graph model' stamp: 'nk 1/23/2004 14:35'! hasModelYellowButtonMenuItems ^Preferences cmdGesturesEnabled! ! !Object methodsFor: '*Tools-Inspector' stamp: 'ajh 1/31/2003 15:49'! basicInspect "Create and schedule an Inspector in which the user can examine the receiver's variables. This method should not be overriden." BasicInspector openOn: self withEvalPane: false! ! !Object methodsFor: '*Tools-Inspector' stamp: 'apb 7/14/2004 12:52'! inspect "Create and schedule an Inspector in which the user can examine the receiver's variables." ^self inspectorClass openOn: self withEvalPane: true! ! !Object methodsFor: '*Tools-Inspector' stamp: 'apb 7/14/2004 12:19'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^ Inspector! ! !Object methodsFor: 'locales' stamp: 'nk 9/3/2004 16:14'! localeChanged "Backstop for notifications"! ! !Object methodsFor: '*Morphic-Worlds' stamp: 'sw 3/20/2001 13:40'! slotInfo "Answer a list of slot-information objects. Initally only provides useful info for players" ^ Dictionary new! ! !Object methodsFor: '*Morphic-Scripting' stamp: 'sw 3/20/2001 13:29'! isUniversalTiles "Return true if I (my world) uses universal tiles. This message can be called in places where the current World is not known, such as when writing out a project. For more information about the project-writing subtlety addressed by this protocol, kindly contact Ted Kaehler." ^ Preferences universalTiles! ! !Object methodsFor: '*Morphic-Scripting' stamp: 'nk 10/14/2004 10:55'! universalTilesForGetterOf: aMethodInterface "Return universal tiles for a getter on the given method interface." | ms argTile argArray itsSelector | itsSelector _ aMethodInterface selector. argArray _ #(). "Four gratuituous special cases..." (itsSelector == #color:sees:) ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. argArray _ Array with: argTile colorSwatch color with: argTile colorSwatch color copy]. itsSelector == #seesColor: ifTrue: [argTile _ ScriptingSystem tileForArgType: #Color. argArray _ Array with: argTile colorSwatch color]. (#(touchesA: overlaps: overlapsAny:) includes: itsSelector) ifTrue: [argTile _ ScriptingSystem tileForArgType: #Player. argArray _ Array with: argTile actualObject]. ms _ MessageSend receiver: self selector: itsSelector arguments: argArray. ^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !Object methodsFor: '*Morphic-Scripting' stamp: 'tk 9/28/2001 13:30'! universalTilesForInterface: aMethodInterface "Return universal tiles for the given method interface. Record who self is." | ms argTile itsSelector aType argList | itsSelector _ aMethodInterface selector. argList _ OrderedCollection new. aMethodInterface argumentVariables doWithIndex: [:anArgumentVariable :anIndex | argTile _ ScriptingSystem tileForArgType: (aType _ aMethodInterface typeForArgumentNumber: anIndex). argList add: (aType == #Player ifTrue: [argTile actualObject] ifFalse: [argTile literal]). "default value for each type"]. ms _ MessageSend receiver: self selector: itsSelector arguments: argList asArray. ^ ms asTilesIn: self class globalNames: (self class officialClass ~~ CardPlayer) "For CardPlayers, use 'self'. For others, name it, and use its name."! ! !Object methodsFor: 'macpal' stamp: 'ar 3/18/2001 00:03'! currentEvent "Answer the current Morphic event. This method never returns nil." ^ActiveEvent ifNil:[self currentHand lastEvent]! ! !Object methodsFor: 'macpal' stamp: 'nk 9/1/2004 10:41'! currentHand "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned." ^ActiveHand ifNil: [ self currentWorld primaryHand ]! ! !Object methodsFor: 'macpal' stamp: 'sw 5/17/2001 12:08'! currentVocabulary "Answer the currently-prevailing default vocabulary." ^ Smalltalk isMorphic ifTrue: [ActiveWorld currentVocabulary] ifFalse: [Vocabulary fullVocabulary]! ! !Object methodsFor: 'macpal' stamp: 'ar 3/18/2001 00:08'! currentWorld "Answer a morphic world that is the current UI focus. If in an embedded world, it's that world. If in a morphic project, it's that project's world. If in an mvc project, it is the topmost morphic-mvc-window's worldMorph. If in an mvc project that has no morphic-mvc-windows, then it's just some existing worldmorph instance. If in an mvc project in a Squeak that has NO WorldMorph instances, one is created. This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one." | aView aSubview | ActiveWorld ifNotNil:[^ActiveWorld]. World ifNotNil:[^World]. aView _ ScheduledControllers controllerSatisfying: [:ctrl | (aSubview _ ctrl view firstSubView) notNil and: [aSubview model isMorph and: [aSubview model isWorldMorph]]]. ^aView ifNotNil: [aSubview model] ifNil: [MVCWiWPasteUpMorph newWorldForProject: nil].! ! !Object methodsFor: 'macpal' stamp: 'gk 2/23/2004 20:51'! playSoundNamed: soundName "Deprecated. Play the sound with the given name." self deprecated: 'Use "SoundService default playSoundNamed: aName" instead.'. SoundService default playSoundNamed: soundName! ! !Object methodsFor: 'macpal' stamp: 'sw 5/22/2001 18:31'! refusesToAcceptCode "Answer whether the receiver is a code-bearing instrument which at the moment refuses to allow its contents to be submitted" ^ false ! ! !Object methodsFor: 'message handling' stamp: 'NS 1/28/2004 11:19'! withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" | selector | <primitive: 188> selector _ Symbol new. self class addSelectorSilently: selector withMethod: compiledMethod. ^ [self perform: selector withArguments: argArray] ensure: [self class basicRemoveSelector: selector]! ! !Object methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 15:04'! fixUponLoad: aProject seg: anImageSegment "change the object due to conventions that have changed on the project level. (sent to all objects in the incoming project). Specific classes should reimplement this."! ! !Object methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:16'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. Does not file out the class of the object. tk 6/26/97 13:48" | aFileName fileStream | aFileName _ self class name asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name?' initialAnswer: aFileName. aFileName size == 0 ifTrue: [^ Beeper beep]. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self.! ! !Object methodsFor: 'objects from disk' stamp: 'tk 8/9/2001 15:40'! storeDataOn: aDataStream "Store myself on a DataStream. Answer self. This is a low-level DataStream/ReferenceStream method. See also objectToStoreOnDataStream. NOTE: This method must send 'aDataStream beginInstance:size:' and then (nextPut:/nextPutWeak:) its subobjects. readDataFrom:size: reads back what we write here." | cntInstVars cntIndexedVars | cntInstVars _ self class instSize. cntIndexedVars _ self basicSize. aDataStream beginInstance: self class size: cntInstVars + cntIndexedVars. 1 to: cntInstVars do: [:i | aDataStream nextPut: (self instVarAt: i)]. "Write fields of a variable length object. When writing to a dummy stream, don't bother to write the bytes" ((aDataStream byteStream class == DummyStream) and: [self class isBits]) ifFalse: [ 1 to: cntIndexedVars do: [:i | aDataStream nextPut: (self basicAt: i)]]. ! ! !Object methodsFor: 'parts bin' stamp: 'sw 10/24/2001 16:34'! descriptionForPartsBin "If the receiver is a member of a class that would like to be represented in a parts bin, answer the name by which it should be known, and a documentation string to be provided, for example, as balloon help. When the 'nativitySelector' is sent to the 'globalReceiver', it is expected that some kind of Morph will result. The parameters used in the implementation below are for documentation purposes only!!" ^ DescriptionForPartsBin formalName: 'PutFormalNameHere' categoryList: #(PutACategoryHere MaybePutAnotherCategoryHere) documentation: 'Put the balloon help here' globalReceiverSymbol: #PutAGlobalHere nativitySelector: #PutASelectorHere! ! !Object methodsFor: 'printing' stamp: 'tk 10/19/2001 11:18'! longPrintOn: aStream limitedTo: sizeLimit indent: indent "Append to the argument, aStream, the names and values of all of the receiver's instance variables. Limit is the length limit for each inst var." self class allInstVarNames doWithIndex: [:title :index | indent timesRepeat: [aStream tab]. aStream nextPutAll: title; nextPut: $:; space; tab; nextPutAll: ((self instVarAt: index) printStringLimitedTo: (sizeLimit -3 -title size max: 1)); cr]! ! !Object methodsFor: 'printing' stamp: 'tk 10/16/2001 19:41'! longPrintString "Answer a String whose characters are a description of the receiver." | str | str _ String streamContents: [:aStream | self longPrintOn: aStream]. "Objects without inst vars should return something" ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! !Object methodsFor: 'printing' stamp: 'BG 11/7/2004 13:39'! longPrintStringLimitedTo: aLimitValue "Answer a String whose characters are a description of the receiver." | str | str _ String streamContents: [:aStream | self longPrintOn: aStream limitedTo: aLimitValue indent: 0]. "Objects without inst vars should return something" ^ str isEmpty ifTrue: [self printString, String cr] ifFalse: [str]! ! !Object methodsFor: 'printing' stamp: 'sw 3/7/2001 13:14'! nominallyUnsent: aSelectorSymbol "From within the body of a method which is not formally sent within the system, but which you intend to have remain in the system (for potential manual invocation, or for documentation, or perhaps because it's sent by commented-out-code that you anticipate uncommenting out someday, send this message, with the selector itself as the argument. This will serve two purposes: (1) The method will not be returned by searches for unsent selectors (because it, in a manner of speaking, sends itself). (2) You can locate all such methods by browsing senders of #nominallyUnsent:" false ifTrue: [self flag: #nominallyUnsent:] "So that this method itself will appear to be sent" ! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'yo 12/25/2003 16:43'! methodInterfacesForCategory: aCategorySymbol inVocabulary: aVocabulary limitClass: aLimitClass "Return a list of methodInterfaces for the receiver in the given category, given a vocabulary. aCategorySymbol is the inherent category symbol, not necessarily the wording as expressed in the vocabulary." | categorySymbol | categorySymbol _ aCategorySymbol asSymbol. (categorySymbol == ScriptingSystem nameForInstanceVariablesCategory) ifTrue: [ "user-defined instance variables" ^ self methodInterfacesForInstanceVariablesCategoryIn: aVocabulary]. (categorySymbol == ScriptingSystem nameForScriptsCategory) ifTrue: [ "user-defined scripts" ^ self methodInterfacesForScriptsCategoryIn: aVocabulary]. "all others" ^ self usableMethodInterfacesIn: (aVocabulary methodInterfacesInCategory: categorySymbol forInstance: self ofClass: self class limitClass: aLimitClass) ! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'sw 8/3/2001 13:54'! methodInterfacesForInstanceVariablesCategoryIn: aVocabulary "Return a collection of methodInterfaces for the instance-variables category. The vocabulary parameter, at present anyway, is not used. And for non-players, the method is at present vacuous in any case" ^ OrderedCollection new! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'sw 8/3/2001 13:53'! methodInterfacesForScriptsCategoryIn: aVocabulary "Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool. The vocabulary argument is not presently used. Also, at present, only Players really do anyting interesting here." ^ OrderedCollection new! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'RAA 2/16/2001 19:37'! selfWrittenAsIll ^self! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'RAA 2/16/2001 19:38'! selfWrittenAsIm ^self! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'RAA 2/16/2001 19:37'! selfWrittenAsMe ^self! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'RAA 2/16/2001 19:37'! selfWrittenAsMy ^self! ! !Object methodsFor: '*Morphic-Tile Scriptors' stamp: 'RAA 2/16/2001 19:38'! selfWrittenAsThis ^self! ! !Object methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:11'! adaptedToWorld: aWorld "If I refer to a world or a hand, return the corresponding items in the new world." ^self! ! !Object methodsFor: 'scripting' stamp: 'sd 11/19/2004 16:57'! contentsGetz: x self deprecated: 'there is no method named contents in object and in addition only one sender in a method not called'. self contents: x! ! !Object methodsFor: 'scripting' stamp: 'RAA 3/9/2001 17:08'! evaluateUnloggedForSelf: aCodeString ^Compiler evaluate: aCodeString for: self logged: false! ! !Object methodsFor: 'system primitives' stamp: 'di 1/9/1999 15:19'! becomeForward: otherObject "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. Fails if either argument is a SmallInteger." (Array with: self) elementsForwardIdentityTo: (Array with: otherObject)! ! !Object methodsFor: 'system primitives' stamp: 'zz 3/3/2004 23:53'! becomeForward: otherObject copyHash: copyHash "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. If copyHash is true, the argument's identity hash bits will be set to those of the receiver. Fails if either argument is a SmallInteger." (Array with: self) elementsForwardIdentityTo: (Array with: otherObject) copyHash: copyHash! ! !Object methodsFor: 'system primitives' stamp: 'ar 3/2/2001 01:34'! primitiveChangeClassTo: anObject "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have. Note: The primitive will fail in most cases that you think might work. This is mostly because of a) the difference between compact and non-compact classes, and b) because of differences in the format. As an example, '(Array new: 3) primitiveChangeClassTo: Morph basicNew' would fail for three of the reasons mentioned above. Array is compact, Morph is not (failure #1). Array is variable and Morph is fixed (different format - failure #2). Morph is a fixed-field-only object and the array is too short (failure #3). The facility is really provided for certain, very specific applications (mostly related to classes changing shape) and not for casual use." <primitive: 115> self primitiveFailed! ! !Object methodsFor: 'testing' stamp: 'sw 9/26/2001 11:58'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Object! ! !Object methodsFor: 'testing' stamp: 'sw 5/3/2001 16:19'! beViewed "Open up a viewer on the receiver. The Presenter is invited to decide just how to present this viewer" self uniqueNameForReference. "So the viewer will have something nice to refer to" self presenter viewObject: self! ! !Object methodsFor: 'testing' stamp: 'sw 1/30/2001 22:24'! haveFullProtocolBrowsed "Open up a Lexicon on the receiver" ^ self haveFullProtocolBrowsedShowingSelector: nil "(2@3) haveFullProtocolBrowsed" ! ! !Object methodsFor: 'testing' stamp: 'sw 3/20/2001 12:20'! haveFullProtocolBrowsedShowingSelector: aSelector "Open up a Lexicon on the receiver, having it open up showing aSelector, which may be nil" | aBrowser | aBrowser _ InstanceBrowser new useVocabulary: Vocabulary fullVocabulary. aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: aSelector "(2@3) haveFullProtocolBrowsed"! ! !Object methodsFor: 'testing' stamp: 'ajh 1/21/2003 13:15'! isBlock ^ false! ! !Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'! isBlockClosure ^ false! ! !Object methodsFor: 'testing' stamp: 'yo 8/28/2002 13:41'! isCharacter ^ false. ! ! !Object methodsFor: 'testing' stamp: 'nk 4/17/2004 19:43'! isColorForm ^false! ! !Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'! isCompiledMethod ^ false! ! !Object methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'! isComplex "Answer true if receiver is a Complex number. False by default." ^ false ! ! !Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'! isForm ^false! ! !Object methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! isHeap ^ false! ! !Object methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ false! ! !Object methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^false ! ! !Object methodsFor: 'testing' stamp: 'gm 2/22/2003 12:56'! isMorphicModel "Return true if the receiver is a morphic model" ^false ! ! !Object methodsFor: 'testing' stamp: 'nk 6/14/2004 16:49'! isSketchMorph ^false! ! !Object methodsFor: 'testing' stamp: 'md 4/30/2003 15:30'! isSymbol ^ false ! ! !Object methodsFor: 'testing' stamp: 'jam 3/9/2003 15:10'! isSystemWindow "answer whatever the receiver is a SystemWindow" ^ false! ! !Object methodsFor: 'testing' stamp: 'ar 8/14/2001 23:19'! isVariableBinding "Return true if I represent a literal variable binding" ^false ! ! !Object methodsFor: 'testing' stamp: 'sw 11/19/2001 13:28'! nameForViewer "Answer a name to be shown in a Viewer that is viewing the receiver" | aName | (aName _ self uniqueNameForReferenceOrNil) ifNotNil: [^ aName]. (aName _ self knownName) ifNotNil: [^ aName]. ^ [(self asString copyWithout: Character cr) truncateTo: 27] ifError: [:msg :rcvr | ^ self class name printString]! ! !Object methodsFor: 'testing' stamp: 'tk 9/6/2001 19:15'! openInstanceBrowserWithTiles "Open up an instance browser on me with tiles as the code type, and with the search level as desired." | aBrowser | aBrowser _ InstanceBrowser new. aBrowser useVocabulary: Vocabulary fullVocabulary. aBrowser limitClass: self class. aBrowser contentsSymbol: #tiles. "preset it to make extra buttons (tile menus)" aBrowser openOnObject: self inWorld: ActiveWorld showingSelector: nil. aBrowser contentsSymbol: #source. aBrowser toggleShowingTiles. " (2@3) openInstanceBrowserWithTiles. WatchMorph new openInstanceBrowserWithTiles "! ! !Object methodsFor: 'testing' stamp: 'sw 2/27/2002 14:55'! renameTo: newName "If the receiver has an inherent idea about its own name, it should take action here. Any object that might be pointed to in the References dictionary might get this message sent to it upon reload"! ! !Object methodsFor: 'testing' stamp: 'sw 5/3/2001 18:22'! vocabularyDemanded "Answer a vocabulary that the receiver insists be used when it is looked at in a Viewer. This allows specific classes to insist on specific custom vocabularies" ^ nil! ! !Object methodsFor: 'testing' stamp: 'sw 11/13/2001 07:26'! wantsDiffFeedback "Answer whether the receiver, serving as the model of a text-bearing entity, would like for 'diffs' green pane-border feedback to be shown" ^ false! ! !Object methodsFor: 'translation support'! inline: inlineFlag "For translation only; noop when running in Smalltalk."! ! !Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:12'! changed: anAspect with: anObject "Receiver changed. The change is denoted by the argument anAspect. Usually the argument is a Symbol that is part of the dependent's change protocol. Inform all of the dependents. Also pass anObject for additional information." self dependents do: [:aDependent | aDependent update: anAspect with: anObject]! ! !Object methodsFor: 'updating' stamp: 'nk 2/17/2004 11:13'! update: anAspect with: anObject "Receive a change notice from an object of whom the receiver is a dependent. The default behavior is to call update:, which by default does nothing; a subclass might want to change itself in some way." ^ self update: anAspect! ! !Object methodsFor: 'user interface' stamp: 'gk 2/24/2004 08:49'! beep "Deprecated." self deprecated: 'Use Beeper class>>beep instead.'. Beeper beep! ! !Object methodsFor: 'user interface' stamp: 'apb 7/14/2004 13:17'! inspectWithLabel: aLabel ^self inspectorClass openOn: self withEvalPane: true withLabel: aLabel! ! !Object methodsFor: 'user interface' stamp: 'sw 6/12/2001 11:09'! launchPartVia: aSelector "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" | aMorph | aMorph _ self perform: aSelector. aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. aMorph openInHand! ! !Object methodsFor: 'user interface' stamp: 'sw 6/17/2004 01:47'! launchPartVia: aSelector label: aString "Obtain a morph by sending aSelector to self, and attach it to the morphic hand. This provides a general protocol for parts bins" | aMorph | aMorph _ self perform: aSelector. aMorph setNameTo: (ActiveWorld unusedMorphNameLike: aString). aMorph setProperty: #beFullyVisibleAfterDrop toValue: true. aMorph openInHand! ! !Object methodsFor: 'user interface' stamp: 'jcg 11/1/2001 13:13'! notYetImplemented self inform: 'Not yet implemented (', thisContext sender printString, ')'! ! !Object methodsFor: 'viewer' stamp: 'sw 12/11/2000 15:37'! browseOwnClassSubProtocol "Open up a ProtocolBrowser on the subprotocol of the receiver" ProtocolBrowser openSubProtocolForClass: self class ! ! !Object methodsFor: 'viewer' stamp: 'sw 8/4/2001 00:51'! categoriesForViewer: aViewer "Answer a list of categories to offer in the given viewer" ^ aViewer currentVocabulary categoryListForInstance: self ofClass: self class limitClass: aViewer limitClass! ! !Object methodsFor: 'viewer' stamp: 'sw 8/3/2001 22:08'! categoriesForVocabulary: aVocabulary limitClass: aLimitClass "Answer a list of categories of methods for the receiver when using the given vocabulary, given that one considers only methods that are implemented not further away than aLimitClass" ^ aVocabulary categoryListForInstance: self ofClass: self class limitClass: aLimitClass! ! !Object methodsFor: 'viewer' stamp: 'sw 8/3/2001 21:22'! defaultLimitClassForVocabulary: aVocabulary "Answer the class to use, by default, as the limit class on a protocol browser or viewer opened up on the receiver, within the purview of the Vocabulary provided" ^ (aVocabulary isKindOf: FullVocabulary) ifTrue: [self class superclass == Object ifTrue: [self class] ifFalse: [self class superclass]] ifFalse: [ProtoObject]! ! !Object methodsFor: 'viewer' stamp: 'sw 5/22/2001 16:53'! elementTypeFor: aStringOrSymbol vocabulary: aVocabulary "Answer a symbol characterizing what kind of element aStringOrSymbol represents. Realistically, at present, this always just returns #systemScript; a prototyped but not-incorporated architecture supported use of a leading colon to characterize an inst var of a system class, and for the moment we still see its remnant here." self flag: #deferred. "a loose end in the non-player case" ^ #systemScript! ! !Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:04'! externalName "Answer an external name by which the receiver is known. Generic implementation here is a transitional backstop. probably" ^ self nameForViewer! ! !Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:06'! graphicForViewerTab "When a Viewer is open on the receiver, its tab needs some graphic to show to the user. Answer a form or a morph to serve that purpose. A generic image is used for arbitrary objects, but note my reimplementors" ^ ScriptingSystem formAtKey: 'Image'! ! !Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 07:08'! hasUserDefinedSlots "Answer whether the receiver has any user-defined slots, in the omniuser sense of the term. This is needed to allow Viewers to look at any object, not just at Players." ^ false! ! !Object methodsFor: 'viewer' stamp: 'sw 8/22/2002 14:07'! infoFor: anElement inViewer: aViewer "The user made a gesture asking for info/menu relating to me. Some of the messages dispatched here are not yet available in this image" | aMenu elementType | elementType _ self elementTypeFor: anElement vocabulary: aViewer currentVocabulary. ((elementType = #systemSlot) | (elementType == #userSlot)) ifTrue: [^ self slotInfoButtonHitFor: anElement inViewer: aViewer]. self flag: #deferred. "Use a traditional MenuMorph, and reinstate the pacify thing" aMenu _ MenuMorph new defaultTarget: aViewer. #( ('implementors' browseImplementorsOf:) ('senders' browseSendersOf:) ('versions' browseVersionsOf:) - ('browse full' browseMethodFull:) ('inheritance' browseMethodInheritance:) - ('about this method' aboutMethod:)) do: [:pair | pair = '-' ifTrue: [aMenu addLine] ifFalse: [aMenu add: pair first target: aViewer selector: pair second argument: anElement]]. aMenu addLine. aMenu defaultTarget: self. #( ('destroy script' removeScript:) ('rename script' renameScript:) ('pacify script' pacifyScript:)) do: [:pair | aMenu add: pair first target: self selector: pair second argument: anElement]. aMenu addLine. aMenu add: 'show categories....' target: aViewer selector: #showCategoriesFor: argument: anElement. aMenu items size == 0 ifTrue: "won't happen at the moment a/c the above" [aMenu add: 'ok' action: nil]. "in case it was a slot -- weird, transitional" aMenu addTitle: anElement asString, ' (', elementType, ')'. aMenu popUpInWorld: self currentWorld. ! ! !Object methodsFor: 'viewer' stamp: 'sw 9/26/2001 11:58'! initialTypeForSlotNamed: aName "Answer the initial type to be ascribed to the given instance variable" ^ #Object! ! !Object methodsFor: 'viewer' stamp: 'ar 5/26/2001 16:13'! isPlayerLike "Return true if the receiver is a player-like object" ^false! ! !Object methodsFor: 'viewer' stamp: 'sw 8/11/2002 02:03'! offerViewerMenuFor: aViewer event: evt "Offer the primary Viewer menu to the user. Copied up from Player code, but most of the functions suggested here don't work for non-Player objects, many aren't even defined, some relate to exploratory sw work not yet reflected in the current corpus. We are early in the life cycle of this method..." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. aMenu title: '**CAUTION -- UNDER CONSTRUCTION!!** Many things may not work!! ', self nameForViewer. (aViewer affordsUniclass and: [self belongsToUniClass not]) ifTrue: [aMenu add: 'give me a Uniclass' action: #assureUniClass. aMenu addLine]. aMenu add: 'choose vocabulary...' target: aViewer action: #chooseVocabulary. aMenu add: 'choose limit class...' target: aViewer action: #chooseLimitClass. aMenu add: 'add search pane' target: aViewer action: #addSearchPane. aMenu balloonTextForLastItem: 'Specify which class should be the most generic one to have its methods shown in this Viewer'. aMenu addLine. self belongsToUniClass ifTrue: [aMenu add: 'add a new instance variable' target: self selector: #addInstanceVariableIn: argument: aViewer. aMenu add: 'add a new script' target: aViewer selector: #newPermanentScriptIn: argument: aViewer. aMenu addLine. aMenu add: 'make my class be first-class' target: self selector: #makeFirstClassClassIn: argument: aViewer. aMenu add: 'move my changes up to my superclass' target: self action: #promoteChangesToSuperclass. aMenu addLine]. aMenu add: 'tear off a tile' target: self selector: #launchTileToRefer. aMenu addLine. aMenu add: 'inspect me' target: self selector: #inspect. aMenu add: 'inspect my class' target: self class action: #inspect. aMenu addLine. aMenu add: 'browse vocabulary' action: #haveFullProtocolBrowsed. aMenu add: 'inspect this Viewer' target: aViewer action: #inspect. aMenu popUpEvent: evt in: aViewer currentWorld " aMenu add: 'references to me' target: aViewer action: #browseReferencesToObject. aMenu add: 'toggle scratch pane' target: aViewer selector: #toggleScratchPane. aMenu add: 'make a nascent script for me' target: aViewer selector: #makeNascentScript. aMenu add: 'rename me' target: aViewer selector: #chooseNewNameForReference. aMenu add: 'browse full' action: #browseOwnClassFull. aMenu add: 'browse hierarchy' action: #browseOwnClassHierarchy. aMenu add: 'set user level...' target: aViewer action: #setUserLevel. aMenu add: 'browse sub-protocol' action: #browseOwnClassSubProtocol. aMenu addLine. "! ! !Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 11:53'! tilePhrasesForCategory: aCategorySymbol inViewer: aViewer "Return a collection of phrases for the category." | interfaces | interfaces _ self methodInterfacesForCategory: aCategorySymbol inVocabulary: aViewer currentVocabulary limitClass: aViewer limitClass. interfaces _ self methodInterfacesInPresentationOrderFrom: interfaces forCategory: aCategorySymbol. ^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer! ! !Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 11:53'! tilePhrasesForMethodInterfaces: methodInterfaceList inViewer: aViewer "Return a collection of ViewerLine objects corresponding to the method-interface list provided. The resulting list will be in the same order as the incoming list, but may be smaller if the viewer's vocbulary suppresses some of the methods, or if, in classic tiles mode, the selector requires more arguments than can be handled." | toSuppress interfaces resultType itsSelector | toSuppress _ aViewer currentVocabulary phraseSymbolsToSuppress. interfaces _ methodInterfaceList reject: [:int | toSuppress includes: int selector]. Preferences universalTiles ifFalse: "Classic tiles have their limitations..." [interfaces _ interfaces select: [:int | itsSelector _ int selector. itsSelector numArgs < 2 or: "The lone two-arg loophole in classic tiles" [#(color:sees:) includes: itsSelector]]]. ^ interfaces collect: [:aMethodInterface | ((resultType _ aMethodInterface resultType) notNil and: [resultType ~~ #unknown]) ifTrue: [aViewer phraseForVariableFrom: aMethodInterface] ifFalse: [aViewer phraseForCommandFrom: aMethodInterface]]! ! !Object methodsFor: 'viewer' stamp: 'sw 8/10/2004 12:23'! tilePhrasesForSelectorList: aList inViewer: aViewer "Particular to the search facility in viewers. Answer a list, in appropriate order, of ViewerLine objects to put into the viewer." | interfaces aVocab | aVocab _ aViewer currentVocabulary. interfaces _ self methodInterfacesInPresentationOrderFrom: (aList collect: [:aSel | aVocab methodInterfaceForSelector: aSel class: self class]) forCategory: #search. ^ self tilePhrasesForMethodInterfaces: interfaces inViewer: aViewer! ! !Object methodsFor: 'viewer' stamp: 'sw 5/4/2001 04:51'! tileToRefer "Answer a reference tile that comprises an alias to me" ^ TileMorph new setToReferTo: self! ! !Object methodsFor: 'viewer' stamp: 'sw 11/21/2001 15:16'! uniqueNameForReference "Answer a nice name by which the receiver can be referred to by other objects. At present this uses a global References dictionary to hold the database of references, but in due course this will need to acquire some locality" | aName nameSym stem knownClassVars | (aName _ self uniqueNameForReferenceOrNil) ifNotNil: [^ aName]. (stem _ self knownName) ifNil: [stem _ self defaultNameStemForInstances asString]. stem _ stem select: [:ch | ch isLetter or: [ch isDigit]]. stem size == 0 ifTrue: [stem _ 'A']. stem first isLetter ifFalse: [stem _ 'A', stem]. stem _ stem capitalized. knownClassVars _ ScriptingSystem allKnownClassVariableNames. aName _ Utilities keyLike: stem satisfying: [:jinaLake | nameSym _ jinaLake asSymbol. ((References includesKey: nameSym) not and: [(Smalltalk includesKey: nameSym) not]) and: [(knownClassVars includes: nameSym) not]]. References at: (aName _ aName asSymbol) put: self. ^ aName! ! !Object methodsFor: 'viewer' stamp: 'sw 3/15/2004 23:53'! uniqueNameForReferenceFrom: proposedName "Answer a satisfactory symbol, similar to the proposedName but obeying the rules, to represent the receiver" | aName nameSym stem okay | proposedName = self uniqueNameForReferenceOrNil ifTrue: [^ proposedName]. "No change" stem _ proposedName select: [:ch | ch isLetter or: [ch isDigit]]. stem size == 0 ifTrue: [stem _ 'A']. stem first isLetter ifFalse: [stem _ 'A', stem]. stem _ stem capitalized. aName _ Utilities keyLike: stem satisfying: [:jinaLake | nameSym _ jinaLake asSymbol. okay _ true. self class scopeHas: nameSym ifTrue: [:x | okay _ false "don't use it"]. okay]. ^ aName asSymbol! ! !Object methodsFor: 'viewer' stamp: 'sw 3/15/2004 23:01'! uniqueNameForReferenceOrNil "If the receiver has a unique name for reference, return it here, else return nil" ^ References keyAtValue: self ifAbsent: [nil]! ! !Object methodsFor: 'viewer' stamp: 'ar 5/16/2001 01:40'! updateThresholdForGraphicInViewerTab "When a Viewer is open on the receiver, its tab needs some graphic to show to the user. Computing this graphic can take quite some time so we want to make the update frequency depending on how long it takes to compute the thumbnail. The threshold returned by this method defines that the viewer will update at most every 'threshold * timeItTakesToDraw' milliseconds. Thus, if the time for computing the receiver's thumbnail is 200 msecs and the the threshold is 10, the viewer will update at most every two seconds." ^20 "seems to be a pretty good general choice"! ! !Object methodsFor: 'viewer' stamp: 'sw 3/9/2001 13:48'! usableMethodInterfacesIn: aListOfMethodInterfaces "Filter aList, returning a subset list of apt phrases" ^ aListOfMethodInterfaces ! ! !Object methodsFor: 'world hacking' stamp: 'ar 3/17/2001 23:45'! couldOpenInMorphic "is there an obvious morphic world in which to open a new morph?" ^World notNil or: [ActiveWorld notNil]! ! !Object methodsFor: 'private' stamp: 'yo 6/29/2004 11:37'! errorNotIndexable "Create an error notification that the receiver is not indexable." self error: ('Instances of {1} are not indexable' translated format: {self class name})! ! !Object methodsFor: 'private' stamp: 'ar 2/6/2004 14:47'! primitiveError: aString "This method is called when the error handling results in a recursion in calling on error: or halt or halt:." | context | (String streamContents: [:s | s nextPutAll: '***System error handling failed***'. s cr; nextPutAll: aString. context _ thisContext sender sender. 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]]. s cr; nextPutAll: '-------------------------------'. s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'. s cr; nextPutAll: 'Type any other character to restart.']) displayAt: 0 @ 0. [Sensor keyboardPressed] whileFalse. Sensor keyboard = Character cr ifTrue: [Transcripter emergencyEvaluator]. Smalltalk isMorphic ifTrue: [World install "init hands and redisplay"] ifFalse: [ScheduledControllers searchForActiveController]! ! !Object methodsFor: '*flexiblevocabularies-viewer' stamp: 'nk 9/11/2004 16:53'! methodInterfacesInPresentationOrderFrom: interfaceList forCategory: aCategory "Answer the interface list sorted in desired presentation order, using a static master-ordering list, q.v. The category parameter allows an escape in case one wants to apply different order strategies in different categories, but for now a single master-priority-ordering is used -- see the comment in method EToyVocabulary.masterOrderingOfPhraseSymbols" | masterOrder ordered unordered index | masterOrder := Vocabulary eToyVocabulary masterOrderingOfPhraseSymbols. ordered := SortedCollection sortBlock: [:a :b | a key < b key]. unordered := SortedCollection sortBlock: [:a :b | a wording < b wording]. interfaceList do: [:interface | index := masterOrder indexOf: interface elementSymbol. index isZero ifTrue: [unordered add: interface] ifFalse: [ordered add: index -> interface]]. ^ Array streamContents: [:stream | ordered do: [:assoc | stream nextPut: assoc value]. stream nextPutAll: unordered]! ! !Object class methodsFor: 'instance creation' stamp: 'sw 1/23/2003 09:45'! categoryForUniclasses "Answer the default system category into which to place unique-class instances" ^ 'UserObjects'! ! !Object class methodsFor: 'instance creation' stamp: 'ajh 5/23/2002 00:35'! newFrom: aSimilarObject "Create an object that has similar contents to aSimilarObject. If the classes have any instance varaibles with the same names, copy them across. If this is bad for a class, override this method." ^ (self isVariable ifTrue: [self basicNew: aSimilarObject basicSize] ifFalse: [self basicNew] ) copySameFrom: aSimilarObject! ! !Object class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:57'! readCarefullyFrom: textStringOrStream "Create an object based on the contents of textStringOrStream. Return an error instead of putting up a SyntaxError window." | object | (Compiler couldEvaluate: textStringOrStream) ifFalse: [^ self error: 'expected String, Stream, or Text']. object _ Compiler evaluate: textStringOrStream for: nil notifying: #error: "signal we want errors" logged: false. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:57'! readFrom: textStringOrStream "Create an object based on the contents of textStringOrStream." | object | (Compiler couldEvaluate: textStringOrStream) ifFalse: [^ self error: 'expected String, Stream, or Text']. object _ Compiler evaluate: textStringOrStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: 'private' stamp: 'mir 8/22/2001 15:20'! releaseExternalSettings "Do nothing as a default"! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 02:00'! flushDependents DependentsFields keysAndValuesDo:[:key :dep| key ifNotNil:[key removeDependent: nil]. ]. DependentsFields finalizeValues.! ! !Object class methodsFor: 'class initialization' stamp: 'rw 2/10/2002 13:09'! flushEvents "Object flushEvents" EventManager flushEvents. ! ! !Object class methodsFor: 'class initialization' stamp: 'rww 10/2/2001 07:35'! initialize "Object initialize" DependentsFields ifNil:[self initializeDependentsFields].! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:41'! initializeDependentsFields "Object initialize" DependentsFields _ WeakIdentityKeyDictionary new. ! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:45'! reInitializeDependentsFields "Object reInitializeDependentsFields" | oldFields | oldFields _ DependentsFields. DependentsFields _ WeakIdentityKeyDictionary new. oldFields keysAndValuesDo:[:obj :deps| deps do:[:d| obj addDependent: d]]. ! ! !Object class methodsFor: 'window color' stamp: 'nk 6/10/2004 08:10'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference. This is a backstop for classes that don't otherwise define a preference." ^ WindowColorSpec classSymbol: self name wording: 'Default' brightColor: #white pastelColor: #white helpMessage: 'Other windows without color preferences.'! ! !Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:41'! fileReaderServicesForDirectory: aFileDirectory "Backstop" ^#()! ! !Object class methodsFor: 'file list services' stamp: 'nk 6/12/2004 11:30'! fileReaderServicesForFile: fullName suffix: suffix "Backstop" ^#()! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'rhi 5/27/2004 17:05'! explorerFor: anObject | window listMorph | rootObject _ anObject. window _ (SystemWindow labelled: self label) model: self. window addMorph: (listMorph _ SimpleHierarchicalListMorph on: self list: #getList selected: #getCurrentSelection changeSelected: #noteNewSelection: menu: #genericMenu: keystroke: #explorerKey:from:) frame: (0@0 corner: 1@0.8). window addMorph: ((PluggableTextMorph on: self text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) askBeforeDiscardingEdits: false) frame: (0@0.8 corner: 1@1). listMorph autoDeselect: false. ^ window! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:16'! getList ^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil) ! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'hg 9/7/2001 12:12'! label ^ rootObject printStringLimitedTo: 32! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:43'! object ^currentSelection ifNotNilDo: [ :cs | cs withoutListWrapper ]! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 10:02'! parentObject currentSelection ifNil: [ ^nil ]. currentSelection parent ifNil: [ ^rootObject ]. ^currentSelection parent withoutListWrapper! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:47'! selector ^currentSelection ifNotNilDo: [ :cs | cs selector ]! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:25'! chasePointers "Open a PointerFinder on the selected item" | path sel savedRoot saved | path _ OrderedCollection new. sel _ currentSelection. [ sel isNil ] whileFalse: [ path addFirst: sel asString. sel _ sel parent ]. path addFirst: #openPath. path _ path asArray. savedRoot _ rootObject. saved _ self object. [ rootObject _ nil. self changed: #getList. (Smalltalk includesKey: #PointerFinder) ifTrue: [PointerFinder on: saved] ifFalse: [self objectReferencesToSelection ]] ensure: [ rootObject _ savedRoot. self changed: #getList. self changed: path. ]! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:25'! defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass _ self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel _ self selector. self systemNavigation browseAllStoresInto: sel from: aClass! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! exploreSelection "Open an ObjectExplorer on the current selection" self object explore! ! !ObjectExplorer methodsFor: 'menus' stamp: 'rhi 5/27/2004 17:27'! explorerKey: aChar from: view "Similar to #genericMenu:..." | insideObject parentObject | currentSelection ifNotNil: [ insideObject _ self object. parentObject _ self parentObject. inspector ifNil: [inspector _ Inspector new]. inspector inspect: parentObject; object: insideObject. aChar == $i ifTrue: [^ self inspectSelection]. aChar == $I ifTrue: [^ self exploreSelection]. aChar == $b ifTrue: [^ inspector browseMethodFull]. aChar == $h ifTrue: [^ inspector classHierarchy]. aChar == $c ifTrue: [^ inspector copyName]. aChar == $p ifTrue: [^ inspector browseFullProtocol]. aChar == $N ifTrue: [^ inspector browseClassRefs]. aChar == $t ifTrue: [^ inspector tearOffTile]. aChar == $v ifTrue: [^ inspector viewerForValue]]. ^ self arrowKey: aChar from: view! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:24'! genericMenu: aMenu "Borrow a menu from my inspector" | insideObject menu parentObject | currentSelection ifNil: [menu _ aMenu. menu add: '*nothing selected*' target: self selector: #yourself] ifNotNil: [insideObject _ self object. parentObject _ self parentObject. inspector ifNil: [inspector _ Inspector new]. inspector inspect: parentObject; object: insideObject. aMenu defaultTarget: inspector. inspector fieldListMenu: aMenu. aMenu items do: [:i | (#(#inspectSelection #exploreSelection #referencesToSelection #defsOfSelection #objectReferencesToSelection #chasePointers ) includes: i selector) ifTrue: [i target: self]]. aMenu addLine; add: 'monitor changes' target: self selector: #monitor: argument: currentSelection]. monitorList isEmptyOrNil ifFalse: [aMenu addLine; add: 'stop monitoring all' target: self selector: #stopMonitoring]. ^ aMenu! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! inspectSelection "Open an Inspector on the current selection" self object inspect! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:00'! objectReferencesToSelection "Open a browser on all references to the selected instance variable, if that's what currently selected. " self systemNavigation browseAllObjectReferencesTo: self object except: (Array with: self parentObject with: currentSelection with: inspector) ifNone: [:obj | self changed: #flash]. ! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! referencesToSelection "Open a browser on all references to the selected instance variable, if that's what's currently selected." | aClass sel | (aClass _ self parentObject class) isVariable ifTrue: [^ self changed: #flash]. sel _ self selector. self systemNavigation browseAllAccessesTo: sel from: aClass! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'sd 3/28/2003 16:27'! openBrowser: aClass Browser newOnClass: aClass! ! !ObjectExplorer methodsFor: 'error handling' stamp: 'nk 7/24/2003 09:29'! doesNotUnderstand: aMessage inspector ifNotNil: [ (inspector respondsTo: aMessage selector) ifTrue: [ ^inspector perform: aMessage selector withArguments: aMessage arguments ]]. ^super doesNotUnderstand: aMessage! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:02'! monitor: anObjectExplorerWrapper "Start stepping and watching the given wrapper for changes." anObjectExplorerWrapper ifNil: [ ^self ]. self world ifNil: [ ^self ]. self monitorList at: anObjectExplorerWrapper put: anObjectExplorerWrapper asString. self world startStepping: self at: Time millisecondClockValue selector: #step arguments: #() stepTime: 200.! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:46'! monitorList ^monitorList ifNil: [ monitorList _ WeakIdentityKeyDictionary new ].! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! release self world ifNotNil: [ self world stopStepping: self selector: #step ]. super release.! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:55'! shouldGetStepsFrom: aWorld ^self monitorList notEmpty! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 18:29'! step "If there's anything in my monitor list, see if the strings have changed." | string changes | changes _ false. self monitorList keysAndValuesDo: [ :k :v | k ifNotNil: [ k refresh. (string _ k asString) ~= v ifTrue: [ self monitorList at: k put: string. changes _ true ]. ] ]. changes ifTrue: [ | sel | sel _ currentSelection. self changed: #getList. self noteNewSelection: sel. ]. self monitorList isEmpty ifTrue: [ ActiveWorld stopStepping: self selector: #step ].! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! stopMonitoring monitorList _ nil. self world stopStepping: self selector: #step! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! world ^ActiveWorld! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:17'! contents (item respondsTo: #explorerContents) ifTrue: [^item explorerContents]. "For all others, show named vars first, then indexed vars" ^(item class allInstVarNames asOrderedCollection withIndexCollect: [:each :index | self class with: (item instVarAt: index) name: each model: item parent: self]) , ((1 to: item basicSize) collect: [:index | self class with: (item basicAt: index) name: index printString model: item parent: self])! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! parent ^parent! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! parent: anObject parent _ anObject! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:49'! selector parent ifNil: [ ^nil ]. ^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! setItem: anObject name: aString model: aModel parent: itemParent parent _ itemParent. self setItem: anObject name: aString model: aModel! ! !ObjectExplorerWrapper methodsFor: 'converting' stamp: 'hg 9/7/2001 19:58'! asString | explorerString string | explorerString _ [item asExplorerString] on: Error do: ['<error in asExplorerString: evaluate "' , itemName , ' asExplorerString" to debug>']. string _ (itemName ifNotNil: [itemName , ': '] ifNil: ['']) , explorerString. (string includes: Character cr) ifTrue: [^ string withSeparatorsCompacted]. ^ string! ! !ObjectExplorerWrapper methodsFor: 'converting' stamp: 'nk 7/24/2003 10:16'! itemName ^itemName! ! !ObjectExplorerWrapper methodsFor: 'monitoring' stamp: 'nk 7/12/2003 18:28'! refresh "hack to refresh item given an object and a string that is either an index or an instance variable name." [ | index | (model class allInstVarNames includes: itemName) ifTrue: [ item _ model instVarNamed: itemName ] ifFalse: [ index _ itemName asNumber. (index between: 1 and: model basicSize) ifTrue: [ item _ model basicAt: index]] ] on: Error do: [ :ex | item _ nil ]! ! !ObjectExplorerWrapper class methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:16'! with: anObject name: aString model: aModel parent: aParent ^self new setItem: anObject name: aString model: aModel parent: aParent ! ! !ObjectFinalizer methodsFor: 'initialize' stamp: 'ar 5/19/2003 20:12'! receiver: aReceiver selector: aSelector argument: anObject receiver := aReceiver. selector := aSelector. arguments := Array with: anObject! ! !ObjectFinalizer methodsFor: 'finalization' stamp: 'ar 5/19/2003 20:13'! finalize "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority." [receiver perform: selector withArguments: arguments] on: Error do:[:ex| ex return]. ! ! !ObjectOut methodsFor: 'fetch from disk' stamp: 'sd 9/24/2004 20:49'! xxxFixup "There is already an object in memory for my url. All pointers to me need to be pointers to him. Can't use become, because other pointers to him must stay valid." | real temp list | real _ page contentsMorph. real == self ifTrue: [page error: 'should be converted by now']. temp _ self. list _ (PointerFinder pointersTo: temp) asOrderedCollection. list add: thisContext. list add: thisContext sender. list do: [:holder | 1 to: holder class instSize do: [:i | (holder instVarAt: i) == temp ifTrue: [holder instVarAt: i put: real]]. 1 to: holder basicSize do: [:i | (holder basicAt: i) == temp ifTrue: [holder basicAt: i put: real]]. ]. ^ real! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'! adjustTargetBorderWidth: aFractionalPoint | n | myTarget borderWidth: (n _ (aFractionalPoint x * 10) rounded max: 0). self showSliderFeedback: n.! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'! adjustTargetGradientDirection: aFractionalPoint | fs p | (fs _ myTarget fillStyle) isGradientFill ifFalse: [^self]. fs direction: (p _ (aFractionalPoint * myTarget extent) rounded). self showSliderFeedback: p. myTarget changed. ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:05'! adjustTargetGradientOrigin: aFractionalPoint | fs p | (fs _ myTarget fillStyle) isGradientFill ifFalse: [^self]. fs origin: (p _ myTarget topLeft + (aFractionalPoint * myTarget extent) rounded). self showSliderFeedback: p. myTarget changed. ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! adjustTargetShadowOffset: aFractionalPoint | n | myTarget changed; layoutChanged. myTarget shadowOffset: (n _ (aFractionalPoint * 4) rounded). self showSliderFeedback: n. myTarget changed; layoutChanged. ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! doEnables | itsName fs | fs _ myTarget fillStyle. self allMorphsDo: [ :each | itsName _ each knownName. itsName == #pickerForColor ifTrue: [ self enable: each when: fs isSolidFill | fs isGradientFill ]. itsName == #pickerForBorderColor ifTrue: [ self enable: each when: (myTarget respondsTo: #borderColor:) ]. itsName == #pickerForShadowColor ifTrue: [ self enable: each when: myTarget hasDropShadow ]. itsName == #pickerFor2ndGradientColor ifTrue: [ self enable: each when: fs isGradientFill ]. ]. ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! makeTargetGradientFill myTarget useGradientFill! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'! makeTargetSolidFill myTarget useSolidFill! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'! numberOneColor myTarget fillStyle isGradientFill ifFalse: [^myTarget color]. ^myTarget fillStyle colorRamp first value ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'gm 2/16/2003 20:36'! numberOneColor: aColor myTarget fillStyle isGradientFill ifFalse: [^(myTarget isSystemWindow) ifTrue: [myTarget setWindowColor: aColor] ifFalse: [myTarget fillStyle: aColor]]. myTarget fillStyle firstColor: aColor forMorph: myTarget hand: nil! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:35'! rebuild self removeAllMorphs. self addARow: { self lockedString: ('Properties for {1}' translated format: {myTarget name}). }. self addARow: { self inAColumn: { self paneForCornerRoundingToggle. self paneForStickinessToggle. self paneForLockedToggle. }. }. self addARow: { self paneForMainColorPicker. self paneFor2ndGradientColorPicker. }. self addARow: { self paneForBorderColorPicker. self paneForShadowColorPicker. }. self addARow: { self buttonNamed: 'Accept' translated action: #doAccept color: color lighter help: 'keep changes made and close panel' translated. self buttonNamed: 'Cancel' translated action: #doCancel color: color lighter help: 'cancel changes made and close panel' translated. }, self rebuildOptionalButtons. thingsToRevert _ Dictionary new. "thingsToRevert at: #fillStyle: put: myTarget fillStyle." myTarget isSystemWindow ifTrue: [ thingsToRevert at: #setWindowColor: put: myTarget paneColorToUse ]. thingsToRevert at: #hasDropShadow: put: myTarget hasDropShadow. thingsToRevert at: #shadowColor: put: myTarget shadowColor. (myTarget respondsTo: #borderColor:) ifTrue: [ thingsToRevert at: #borderColor: put: myTarget borderColor. ]. thingsToRevert at: #borderWidth: put: myTarget borderWidth. thingsToRevert at: #cornerStyle: put: myTarget cornerStyle. thingsToRevert at: #sticky: put: myTarget isSticky. thingsToRevert at: #lock: put: myTarget isLocked. ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:37'! rebuildOptionalButtons | answer | answer _ { self transparentSpacerOfSize: 20@3. self buttonNamed: 'Button' translated action: #doButtonProperties color: color lighter help: 'open a button properties panel for the morph' translated. }. myTarget isTextMorph ifTrue: [ answer _ answer, { self buttonNamed: 'Text' translated action: #doTextProperties color: color lighter help: 'open a text properties panel for the morph' translated. }. ]. ^answer! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'ar 8/25/2001 18:30'! targetBorderColor ^myTarget borderStyle baseColor! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'ar 11/26/2001 15:29'! targetBorderColor: aColor "Need to replace the borderStyle or BorderedMorph will not 'feel' the change" myTarget borderStyle: (myTarget borderStyle copy baseColor: aColor).! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:04'! targetHasGradientFill ^myTarget fillStyle isGradientFill! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:01'! targetHasSolidFill ^myTarget fillStyle isSolidFill! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! targetRadial myTarget fillStyle isGradientFill ifFalse: [^false]. ^myTarget fillStyle radial! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! tgt2ndGradientColor myTarget fillStyle isGradientFill ifFalse: [^Color black]. ^myTarget fillStyle colorRamp last value! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:03'! tgt2ndGradientColor: aColor myTarget fillStyle lastColor: aColor forMorph: myTarget hand: nil ! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:45'! toggleTargetGradientFill self targetHasGradientFill ifTrue: [ self makeTargetSolidFill ] ifFalse: [ self makeTargetGradientFill ]. self doEnables! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 3/8/2001 18:02'! toggleTargetRadial | fs | (fs _ myTarget fillStyle) isGradientFill ifFalse: [^self]. fs radial: fs radial not. myTarget changed. self doEnables.! ! !ObjectPropertiesMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 17:48'! toggleTargetSolidFill self targetHasSolidFill ifTrue: [ self makeTargetGradientFill ] ifFalse: [ self makeTargetSolidFill ]. self doEnables! ! !ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ self defaultColor darker! ! !ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.548 g: 0.839 b: 0.452! ! !ObjectPropertiesMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:44'! initialize "initialize the state of the receiver" super initialize. "" myTarget ifNil: [myTarget _ RectangleMorph new openInWorld]. self rebuild! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'sd 11/13/2003 21:03'! borderPrototype: aBorderStyle help: helpString | selector proto | selector _ BorderedMorph new. selector borderWidth: 0. selector color: Color transparent. proto _ Morph new extent: 16@16. proto color: Color transparent. proto borderStyle: aBorderStyle. selector extent: proto extent + 4. selector addMorphCentered: proto. (myTarget canDrawBorder: aBorderStyle) ifTrue:[ selector setBalloonText: helpString. selector on: #mouseDown send: #toggleBorderStyle:with:from: to: self withValue: proto. (myTarget borderStyle species == aBorderStyle species and:[ myTarget borderStyle style == aBorderStyle style]) ifTrue:[selector borderWidth: 1]. ] ifFalse:[ selector setBalloonText: 'This border style cannot be used here' translated. selector on: #mouseDown send: #beep to: Beeper. selector addMorphCentered: ((Morph new) color: (Color black alpha: 0.5); extent: selector extent). ]. ^selector! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'! paneFor2ndGradientColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: self getter: #tgt2ndGradientColor setter: #tgt2ndGradientColor:. self lockedString: '2nd gradient color' translated. self paneForRadialGradientToggle hResizing: #shrinkWrap. ( self inARow: {self paneForGradientOrigin. self paneForGradientDirection} ) hResizing: #shrinkWrap. } named: #pickerFor2ndGradientColor) layoutInset: 0. self paneForGradientFillToggle hResizing: #shrinkWrap } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:23'! paneForBorderColorPicker ^self inAColumn: { self colorPickerFor: self getter: #targetBorderColor setter: #targetBorderColor:. self lockedString: 'Border Color' translated. (self paneForBorderStyle) hResizing: #shrinkWrap; layoutInset: 5. self lockedString: 'Border style' translated. self paneForBorderWidth. } named: #pickerForBorderColor. ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:25'! paneForBorderStyle ^self inARow: { self borderPrototype: (BorderStyle width: 4 color: Color black) help:'Click to select a simple colored border' translated. self borderPrototype: (BorderStyle raised width: 4) help:'Click to select a simple raised border' translated. self borderPrototype: (BorderStyle inset width: 4) help:'Click to select a simple inset border' translated. self borderPrototype: (BorderStyle complexFramed width: 4) help:'Click to select a complex framed border' translated. self borderPrototype: (BorderStyle complexRaised width: 4) help:'Click to select a complex raised border' translated. self borderPrototype: (BorderStyle complexInset width: 4) help:'Click to select a complex inset border' translated. self borderPrototype: (BorderStyle complexAltFramed width: 4) help:'Click to select a complex framed border' translated. self borderPrototype: (BorderStyle complexAltRaised width: 4) help:'Click to select a complex raised border' translated. self borderPrototype: (BorderStyle complexAltInset width: 4) help:'Click to select a complex inset border' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:29'! paneForBorderWidth ^(self inARow: { self buildFakeSlider: 'Border width' translated selector: #adjustTargetBorderWidth: help: 'Drag in here to change the border width' translated }) hResizing: #shrinkWrap ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18'! paneForCornerRoundingToggle ^self inARow: { self directToggleButtonFor: myTarget getter: #wantsRoundedCorners setter: #toggleCornerRounding help: 'Turn rounded corners on or off' translated. self lockedString: ' Rounded corners' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:40'! paneForDropShadowToggle ^self inARow: { self directToggleButtonFor: myTarget getter: #hasDropShadow setter: #toggleDropShadow help: 'Turn drop shadows on or off' translated. self lockedString: ' Drop shadow color' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22'! paneForGradientDirection ^(self inARow: { self buildFakeSlider: 'Direction' translated selector: #adjustTargetGradientDirection: help: 'Drag in here to change the direction of the gradient' translated }) hResizing: #shrinkWrap ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:22'! paneForGradientFillToggle ^self inARow: { self directToggleButtonFor: self getter: #targetHasGradientFill setter: #toggleTargetGradientFill help: 'Turn gradient fill on or off' translated. self lockedString: ' Gradient fill' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'! paneForGradientOrigin ^(self inARow: { self buildFakeSlider: 'Origin' translated selector: #adjustTargetGradientOrigin: help: 'Drag in here to change the origin of the gradient' translated }) hResizing: #shrinkWrap ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:19'! paneForLockedToggle ^self inARow: { self directToggleButtonFor: myTarget getter: #isLocked setter: #toggleLocked help: 'Turn lock on or off' translated. self lockedString: ' Lock' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20'! paneForMainColorPicker ^self inAColumn: { self colorPickerFor: self getter: #numberOneColor setter: #numberOneColor:. self lockedString: 'Color' translated. (self paneForSolidFillToggle) hResizing: #shrinkWrap. } named: #pickerForColor. ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:21'! paneForRadialGradientToggle ^self inARow: { self directToggleButtonFor: self getter: #targetRadial setter: #toggleTargetRadial help: 'Turn radial gradient on or off' translated. self lockedString: ' Radial gradient' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'RAA 3/8/2001 18:03'! paneForShadowColorPicker ^self inAColumn: { (self inAColumn: { self colorPickerFor: myTarget getter: #shadowColor setter: #shadowColor:. self paneForShadowOffset. } named: #pickerForShadowColor) layoutInset: 0. self paneForDropShadowToggle hResizing: #shrinkWrap. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:36'! paneForShadowOffset ^(self inARow: { self buildFakeSlider: 'Offset' translated selector: #adjustTargetShadowOffset: help: 'Drag in here to change the offset of the shadow' translated }) hResizing: #shrinkWrap ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:20'! paneForSolidFillToggle ^self inARow: { self directToggleButtonFor: self getter: #targetHasSolidFill setter: #toggleTargetSolidFill help: 'Turn solid fill on or off' translated. self lockedString: ' Solid fill' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'dgd 8/31/2003 21:18'! paneForStickinessToggle ^self inARow: { self directToggleButtonFor: myTarget getter: #isSticky setter: #toggleStickiness help: 'Turn stickiness on or off' translated. self lockedString: ' Sticky' translated. } ! ! !ObjectPropertiesMorph methodsFor: 'panes' stamp: 'ar 8/25/2001 18:35'! toggleBorderStyle: provider with: arg1 from: arg2 | oldStyle newStyle | oldStyle _ myTarget borderStyle. newStyle _ provider borderStyle copy. oldStyle width = 0 ifTrue:[newStyle width: 2] ifFalse:[newStyle width: oldStyle width]. newStyle baseColor: oldStyle baseColor. myTarget borderStyle: newStyle. provider owner owner submorphsDo:[:m| m borderWidth: 0]. provider owner borderWidth: 1.! ! !ObjectScanner methodsFor: 'as yet unclassified' stamp: 'yo 11/11/2002 10:27'! lookAhead: aChunk "See if this chunk is a class Definition, and if the new class name already exists and is instance-specific. Modify the chunk, and record the rename in the SmartRefStream and in me." | pieces sup oldName existing newName newDefn | aChunk size < 90 ifTrue: [^ aChunk]. "class defn is big!!" (aChunk at: 1) == $!! ifTrue: [^ aChunk]. "method def, fast exit" pieces _ (aChunk copyFrom: 1 to: (300 min: aChunk size)) findTokens: ' # \' withCRs. pieces size < 3 ifTrue: [^ aChunk]. "really bigger, but just took front" (pieces at: 2) = 'subclass:' ifFalse: [^ aChunk]. sup _ Smalltalk at: (pieces at: 1) asSymbol ifAbsent: [^ aChunk]. sup class class == Metaclass ifFalse: [^ aChunk]. ((oldName _ pieces at: 3) at: 1) canBeGlobalVarInitial ifFalse: [^ aChunk]. oldName _ oldName asSymbol. (Smalltalk includesKey: oldName) ifFalse: [^ aChunk]. "no conflict" existing _ Smalltalk at: oldName. (existing isKindOf: Class) ifFalse: [^ aChunk]. "Write over non-class global" existing isSystemDefined ifTrue: [^ aChunk]. "Go ahead and redefine it!!" "Is a UniClass" newName _ sup chooseUniqueClassName. newDefn _ aChunk copyReplaceAll: oldName with: newName. Compiler evaluate: newDefn for: self logged: true. "Create the new class" self rename: oldName toBe: newName. ^ newName asString "to be evaluated" ! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! a self b.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! a1 self b1.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! b self haltIf: #testHaltIf.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! b1 self haltIf: #testasdasdfHaltIf.! ! !ObjectTest methodsFor: 'testing - debugging' stamp: 'm 8/12/2003 17:26'! testAssert self shouldnt: [Object assert: [true]] raise: Error. self shouldnt: [Object assert: true] raise: Error. self should: [Object assert: [false]] raise: AssertionFailure. self should: [Object assert: false] raise: AssertionFailure.! ! !ObjectTest methodsFor: 'testing - debugging' stamp: 'md 10/17/2004 18:39'! testHaltIf self should: [self haltIf: true] raise: Halt. self shouldnt: [self haltIf: false] raise: Halt. self should: [self haltIf: [true]] raise: Halt. self shouldnt: [self haltIf: [false]] raise: Halt. self should: [self haltIf: #testHaltIf.] raise: Halt. self shouldnt: [self haltIf: #teadfasdfltIf.] raise: Halt. self should: [self a] raise: Halt. self shouldnt: [self a1] raise: Halt. self should: [self haltIf: [:o | o class = self class]] raise: Halt. self shouldnt: [self haltIf: [:o | o class ~= self class]] raise: Halt. ! ! !ObjectTest methodsFor: 'testing' stamp: 'md 11/26/2004 16:37'! testBecome "self debug: #testBecome" "this test should that all the variables pointing to an object are pointing now to another one, and all object pointing to the other are pointing to the object" | pt1 pt2 pt3 | pt1 := 0@0. pt2 := pt1. pt3 := 100@100. pt1 become: pt3. self assert: pt2 = (100@100). self assert: pt3 = (0@0). self assert: pt1 = (100@100).! ! !ObjectTest methodsFor: 'testing' stamp: 'md 11/26/2004 16:36'! testBecomeForward "self debug: #testBecomeForward" "this test should that all the variables pointing to an object are pointing now to another one. Not that this inverse is not true. This kind of become is called oneWayBecome in VW" | pt1 pt2 pt3 | pt1 := 0@0. pt2 := pt1. pt3 := 100@100. pt1 becomeForward: pt3. self assert: pt2 = (100@100). self assert: pt3 == pt2. self assert: pt1 = (100@100)! ! !ObjectTracer methodsFor: 'very few messages' stamp: 'hg 10/2/2001 20:43'! doesNotUnderstand: aMessage "All external messages (those not caused by the re-send) get trapped here" "Present a dubugger before proceeding to re-send the message" Debugger openContext: thisContext label: 'About to perform: ', aMessage selector contents: nil. ^ aMessage sentTo: tracedObject. ! ! !ObjectWithDocumentation methodsFor: 'documentation' stamp: 'yo 2/11/2005 15:41'! editDescription "Allow the user to see and edit the documentation for this object" | reply helpMessage | helpMessage _ self documentation isNil ifTrue: [String new] ifFalse: [self documentation]. reply _ FillInTheBlank multiLineRequest: 'Kindly edit the description' translated centerAt: Sensor cursorPoint initialAnswer: helpMessage answerHeight: 200. reply isEmptyOrNil ifFalse: [self documentation: reply]! ! !ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'sw 9/12/2001 23:03'! elementSymbol "Answer the receiver's element symbol" ^ elementSymbol! ! !ObjectWithDocumentation methodsFor: 'miscellaneous' stamp: 'mir 7/12/2004 23:20'! naturalLanguageTranslations ^naturalLanguageTranslations ifNil: [OrderedCollection new]! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:21'! documentation "Answer the receiver's documentation" ^self helpMessage! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:33'! documentation: somethingUsefulHopefully "Set the receiver's documentation, in the current langauge" self helpMessage: somethingUsefulHopefully! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'sw 8/18/2004 20:23'! helpMessage "Check if there is a getterSetterHelpMessage. Otherwise try the normal help message or return nil." ^ self getterSetterHelpMessage ifNil: [(self propertyAt: #helpMessage ifAbsent: [self legacyHelpMessage ifNil: [^ nil]]) translated]! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 19:32'! helpMessage: somethingUsefulHopefully "Set the receiver's documentation, in the current langauge" self propertyAt: #helpMessage put: somethingUsefulHopefully! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'sw 8/18/2004 22:11'! legacyHelpMessage "If I have a help message stashed in my legacy naturalTranslations slot, answer its translated rendition, else answer nil. If I *do* come across a legacy help message, transfer it to my properties dictionary." | untranslated | naturalLanguageTranslations isEmptyOrNil "only in legacy (pre-3.8) projects" ifTrue: [^ nil]. untranslated _ naturalLanguageTranslations first helpMessage ifNil: [^ nil]. self propertyAt: #helpMessage put: untranslated. naturalLanguageTranslations removeFirst. naturalLanguageTranslations isEmpty ifTrue: [naturalLanguageTranslations _ nil]. ^ untranslated translated! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 23:57'! untranslatedHelpMessage "Check if there is a getterSetterHelpMessage. Otherwise try the normal help message or return nil." ^(self propertyAt: #getterSetterHelpMessage ifAbsent: [nil]) ifNil: [(self propertyAt: #helpMessage ifAbsent: [nil])]! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 23:56'! untranslatedWording "Answer the receiver's wording" ^self propertyAt: #wording ifAbsent: [nil]! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:34'! wording "Answer the receiver's wording" | wording | (wording := self propertyAt: #wording ifAbsent: [nil]) ifNotNil: [^wording translated]. self initWordingAndDocumentation. ^self propertyAt: #wording ifAbsent: ['']! ! !ObjectWithDocumentation methodsFor: 'accessing' stamp: 'mir 7/12/2004 21:39'! wording: aString "Set the receiver's wording, in the current langauge" self propertyAt: #wording put: aString! ! !ObjectWithDocumentation methodsFor: 'migration' stamp: 'mir 7/12/2004 23:45'! migrateWordAndHelpMessage "Migrate the English wording and help message to the new structure" | englishElement | self initWordingAndDocumentation. (self properties includes: #wording) ifFalse: [ englishElement := self naturalLanguageTranslations detect: [:each | each language == #English] ifNone: [^nil]. self wording: englishElement wording. self helpMessage: englishElement helpMessage]! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:28'! getterSetterHelpMessage "Returns a helpMessage that has been computed previously and needs to be translated and then formatted with the elementSymbol. 'get value of {1}' translated format: {elSym}" ^(self propertyAt: #getterSetterHelpMessage ifAbsent: [^nil]) translated format: {self elementSymbol}! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:29'! getterSetterHelpMessage: aString "Sets a helpMessage that needs to be translated and then formatted with the elementSymbol. 'get value of {1}' translated format: {elSym}" self propertyAt: #getterSetterHelpMessage put: aString! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 21:31'! initWordingAndDocumentation "Initialize wording and documentation (helpMessage) for getters and setters" | elSym | elSym := self elementSymbol. elSym ifNil: [^self]. ((elSym beginsWith: 'get') and: [elSym size > 3]) ifTrue: [ self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted. self getterSetterHelpMessage: 'get value of {1}'] ifFalse: [ ((elSym beginsWith: 'set') and: [elSym size > 4]) ifTrue: [ self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted. self getterSetterHelpMessage: 'set value of {1}']]! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:30'! properties ^properties ifNil: [properties := Dictionary new]! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:30'! propertyAt: key ^self propertyAt: key ifAbsent: [nil]! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'! propertyAt: key ifAbsent: aBlock ^properties ifNil: aBlock ifNotNil: [properties at: key ifAbsent: aBlock]! ! !ObjectWithDocumentation methodsFor: 'private' stamp: 'mir 7/12/2004 19:29'! propertyAt: key put: aValue self properties at: key put: aValue! ! !ObjectWithDocumentation commentStamp: '<historical>' prior: 0! ObjectWithDocumentation - an abstract superclass for objects that allows maintenance of an authoring stamp, a body of documentation, and a properties dictionary. The Properties implementation has not happened yet -- it would closely mirror the implemenation of properties in the MorphExtension, for example.! !ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:38'! classVar ^ ClassVar! ! !ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:54'! initialize "self initialize" Transcript show: 'Initializing ObjectWithInitialize. classVar state was: ', ClassVar asString; cr. ClassVar isNil ifTrue: [ClassVar := 1] ifFalse: [ClassVar := 2]. Transcript show: 'After initializing ObjectWithInitialize. classVar state is: ', ClassVar asString; cr.! ! !ObjectWithInitialize class methodsFor: 'initialize' stamp: 'sd 11/11/2003 13:39'! reset "self reset" ClassVar := nil! ! !ObjectsTool methodsFor: 'alphabetic' stamp: 'sw 8/12/2001 17:32'! alphabeticTabs "Answer a list of buttons which, when hit, will trigger the choice of a morphic category" | buttonList aButton tabLabels | tabLabels _ (($a to: $z) collect: [:ch | ch asString]) asOrderedCollection. buttonList _ tabLabels collect: [:catName | aButton _ SimpleButtonMorph new label: catName. aButton actWhen: #buttonDown. aButton target: self; actionSelector: #showAlphabeticCategory:fromButton:; arguments: {catName. aButton}]. ^ buttonList "ObjectsTool new tabsForMorphicCategories"! ! !ObjectsTool methodsFor: 'alphabetic' stamp: 'nk 9/3/2004 13:47'! installQuads: quads fromButton: aButton "Install items in the bottom pane that correspond to the given set of quads, as triggered from the given button" | aPartsBin sortedQuads oldResizing | aPartsBin _ self partsBin. oldResizing := aPartsBin vResizing. aPartsBin removeAllMorphs. sortedQuads _ (PartsBin translatedQuads: quads) asSortedCollection: [:a :b | a third < b third]. aPartsBin listDirection: #leftToRight quadList: sortedQuads. aButton ifNotNil: [self tabsPane highlightOnlySubmorph: aButton]. aPartsBin vResizing: oldResizing. aPartsBin layoutChanged; fullBounds. self isFlap ifFalse: [ self minimizePartsBinSize ].! ! !ObjectsTool methodsFor: 'alphabetic' stamp: 'nk 9/3/2004 12:13'! showAlphabeticTabs "Switch to the mode of showing alphabetic tabs" modeSymbol == #alphabetic ifTrue: [ ^self ]. self partsBin removeAllMorphs. self initializeWithTabs: self alphabeticTabs. self modeSymbol: #alphabetic. self tabsPane submorphs first doButtonAction! ! !ObjectsTool methodsFor: 'categories' stamp: 'nk 9/3/2004 13:43'! showCategories "Set the receiver up so that it shows tabs for each of the standard categories" modeSymbol == #categories ifTrue: [ ^self ]. self partsBin removeAllMorphs. self initializeWithTabs: self tabsForCategories. self modeSymbol: #categories. self tabsPane submorphs first doButtonAction. ! ! !ObjectsTool methodsFor: 'categories' stamp: 'nk 9/3/2004 13:51'! showCategory: aCategoryName fromButton: aButton "Project items from the given category into my lower pane" | quads | self partsBin removeAllMorphs. Cursor wait showWhile: [quads := OrderedCollection new. Morph withAllSubclasses do: [:aClass | aClass theNonMetaClass addPartsDescriptorQuadsTo: quads if: [:aDescription | aDescription translatedCategories includes: aCategoryName]]. quads := quads asSortedCollection: [:q1 :q2 | q1 third <= q2 third]. self installQuads: quads fromButton: aButton]! ! !ObjectsTool methodsFor: 'categories' stamp: 'nk 8/23/2004 18:18'! tabsForCategories "Answer a list of buttons which, when hit, will trigger the choice of a category" | buttonList aButton classes categoryList basic | classes _ Morph withAllSubclasses. categoryList _ Set new. classes do: [:aClass | (aClass class includesSelector: #descriptionForPartsBin) ifTrue: [categoryList addAll: aClass descriptionForPartsBin translatedCategories]. (aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue: [aClass supplementaryPartsDescriptions do: [:aDescription | categoryList addAll: aDescription translatedCategories]]]. categoryList _ OrderedCollection withAll: (categoryList asSortedArray). basic := categoryList remove: ' Basic' translated ifAbsent: [ ]. basic ifNotNil: [ categoryList addFirst: basic ]. basic := categoryList remove: 'Basic' translated ifAbsent: [ ]. basic ifNotNil: [ categoryList addFirst: basic ]. buttonList _ categoryList collect: [:catName | aButton _ SimpleButtonMorph new label: catName. aButton actWhen: #buttonDown. aButton target: self; actionSelector: #showCategory:fromButton:; arguments: {catName. aButton}]. ^ buttonList "ObjectsTool new tabsForCategories"! ! !ObjectsTool methodsFor: 'initialization' stamp: 'nk 9/3/2004 13:46'! initializeForFlap "Initialize the receiver to operate in a flap at the top of the screen." " Flaps newObjectsFlap openInWorld " | buttonPane aBin aColor heights tabsPane | self basicInitialize. self layoutInset: 0; layoutPolicy: ProportionalLayout new; hResizing: #shrinkWrap; vResizing: #rigid; borderWidth: 2; borderColor: Color darkGray; extent: (self minimumWidth @ self minimumHeight). "mode buttons" buttonPane := self paneForTabs: self modeTabs. buttonPane vResizing: #shrinkWrap; setNameTo: 'ButtonPane'; color: (aColor := buttonPane color) darker; layoutInset: 6; wrapDirection: nil; width: self width; layoutChanged; fullBounds. "Place holder for a tabs or text pane" tabsPane := Morph new setNameTo: 'TabPane'; hResizing: #spaceFill; yourself. heights := { buttonPane height. 40 }. buttonPane vResizing: #spaceFill. self addMorph: buttonPane fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ 0 corner: 0 @ heights first)). self addMorph: tabsPane fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ heights first corner: 0 @ (heights first + heights second))). aBin := (PartsBin newPartsBinWithOrientation: #leftToRight from: #()) listDirection: #leftToRight; wrapDirection: #topToBottom; color: aColor lighter lighter; setNameTo: 'Parts'; dropEnabled: false; vResizing: #spaceFill; yourself. self addMorph: aBin fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ (heights first + heights second) corner: 0 @ 0)). aBin color: (Color orange muchLighter); setNameTo: 'Objects' translated. self color: (Color orange muchLighter); setNameTo: 'Objects' translated. ! ! !ObjectsTool methodsFor: 'initialization' stamp: 'nk 9/3/2004 12:06'! initializeToStandAlone "Initialize the receiver so that it can live as a stand-alone morph" | buttonPane aBin aColor heights tabsPane | self basicInitialize. self layoutInset: 6; layoutPolicy: ProportionalLayout new; useRoundedCorners; hResizing: #rigid; vResizing: #rigid; extent: (self minimumWidth @ self minimumHeight). "mode buttons" buttonPane := self paneForTabs: self modeTabs. buttonPane vResizing: #shrinkWrap; setNameTo: 'ButtonPane'; addMorphFront: self dismissButton; addMorphBack: self helpButton; color: (aColor := buttonPane color) darker; layoutInset: 6; wrapDirection: nil; width: self width; layoutChanged; fullBounds. "Place holder for a tabs or text pane" tabsPane := Morph new setNameTo: 'TabPane'; hResizing: #spaceFill; yourself. heights := { buttonPane height. 40 }. buttonPane vResizing: #spaceFill. self addMorph: buttonPane fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ 0 corner: 0 @ heights first)). self addMorph: tabsPane fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 0) offsets: (0 @ heights first corner: 0 @ (heights first + heights second))). aBin := (PartsBin newPartsBinWithOrientation: #leftToRight from: #()) listDirection: #leftToRight; wrapDirection: #topToBottom; color: aColor lighter lighter; setNameTo: 'Parts'; dropEnabled: false; vResizing: #spaceFill; yourself. self addMorph: aBin fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ (heights first + heights second) corner: 0 @ 0)). self color: (Color r: 0.0 g: 0.839 b: 0.226); setNameTo: 'Objects' translated; showCategories. ! ! !ObjectsTool methodsFor: 'initialization' stamp: 'nk 9/3/2004 13:19'! tweakAppearanceAfterModeShift "After the receiver has been put into a given mode, make an initial selection of category, if appropriate, and highlight the mode button." self buttonPane submorphs do: [:aButton | aButton borderWidth: 0. (aButton valueOfProperty: #modeSymbol) = modeSymbol ifTrue: [aButton firstSubmorph color: Color red] ifFalse: [aButton firstSubmorph color: Color black]]. ! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:35'! extent: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" self extent = anExtent ifTrue: [ ^self ]. super extent: anExtent. self fixLayoutFrames.! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 13:44'! fixLayoutFrames "Adjust the boundary between the tabs or search pane and the parts bin, giving preference to the tabs." | oldY newY tp tpHeight | oldY := ((tp := self tabsPane ifNil: [self searchPane]) ifNil: [^ self]) layoutFrame bottomOffset. tpHeight := tp hasSubmorphs ifTrue: [(tp submorphBounds outsetBy: tp layoutInset) height] ifFalse: [tp height]. newY := (self buttonPane ifNil: [^ self]) height + tpHeight. oldY = newY ifTrue: [^ self]. tp layoutFrame bottomOffset: newY. (self partsBin ifNil: [^ self]) layoutFrame topOffset: newY. submorphs do: [:m | m layoutChanged ]! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 13:47'! minimizePartsBinSize self layoutChanged; fullBounds. self fixLayoutFrames. self setExtentFromHalo: (self minimumWidth @ self minimumHeight) ! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 10:35'! minimumBottom | iconsBottom partsBin | partsBin := self partsBin ifNil: [ ^self bottom ]. iconsBottom := partsBin submorphs isEmpty ifTrue: [ partsBin top + 60 ] ifFalse: [ partsBin submorphBounds bottom + partsBin layoutInset ]. ^iconsBottom + self layoutInset + self borderWidth! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 11:53'! minimumHeight ^(self minimumBottom - self top) max: 280! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:06'! minimumWidth "Answer a width that assures that the alphabet fits in two rows" ^ 300! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:40'! position: aPoint "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" self position = aPoint ifTrue: [ ^self ]. super position: aPoint. self fixLayoutFrames.! ! !ObjectsTool methodsFor: 'layout' stamp: 'nk 9/3/2004 12:44'! setExtentFromHalo: anExtent "The user has dragged the grow box such that the receiver's extent would be anExtent. Do what's needed" super setExtentFromHalo: ((anExtent x max: self minimumWidth) @ (anExtent y max: self minimumHeight)). ! ! !ObjectsTool methodsFor: 'major modes' stamp: 'sw 8/12/2001 16:30'! modeSymbol "Answer the modeSymbol" ^ modeSymbol! ! !ObjectsTool methodsFor: 'major modes' stamp: 'nk 9/3/2004 13:32'! modeSymbol: aSymbol "Set the receiver's modeSymbol as indicated" modeSymbol _ aSymbol. self tweakAppearanceAfterModeShift. ! ! !ObjectsTool methodsFor: 'major modes' stamp: 'dgd 8/30/2003 16:11'! modeTabs "Answer a list of buttons which, when hit, will trigger the choice of mode of the receiver" | buttonList aButton tupleList | tupleList _ #( ('alphabetic' alphabetic showAlphabeticTabs 'A separate tab for each letter of the alphabet') ('find' search showSearchPane 'Provides a type-in pane allowing you to match') ('categories' categories showCategories 'Grouped by category') "('standard' standard showStandardPane 'Standard Squeak tools supplies for building')" ). buttonList _ tupleList collect: [:tuple | aButton _ SimpleButtonMorph new label: tuple first translated. aButton actWhen: #buttonUp. aButton setProperty: #modeSymbol toValue: tuple second. aButton target: self; actionSelector: tuple third. aButton setBalloonText: tuple fourth translated. aButton]. ^ buttonList "ObjectsTool new modeTabs"! ! !ObjectsTool methodsFor: 'menu' stamp: 'dgd 8/30/2003 16:22'! addCustomMenuItems: aMenu hand: aHand "Add items to the given halo-menu, given a hand" super addCustomMenuItems: aMenu hand: aHand. aMenu addLine. aMenu add: 'alphabetic' translated target: self selector: #showAlphabeticTabs. aMenu add: 'find' translated target: self selector: #showSearchPane. aMenu add: 'categories' translated target: self selector: #showCategories. aMenu addLine. aMenu add: 'reset thumbnails' translated target: self selector: #resetThumbnails.! ! !ObjectsTool methodsFor: 'menu' stamp: 'nk 9/7/2003 07:42'! resetThumbnails "Reset the thumbnail cache" PartsBin clearThumbnailCache. modeSymbol == #categories ifTrue: [self showCategories] ifFalse: [self showAlphabeticTabs]! ! !ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 11:20'! newSearchPane "Answer a type-in pane for searches" | aTextMorph | aTextMorph _ TextMorph new setProperty: #defaultContents toValue: ('' asText allBold addAttribute: (TextFontChange font3)); setTextStyle: (TextStyle fontArray: { Preferences standardEToysFont }); setDefaultContentsIfNil; on: #keyStroke send: #searchPaneCharacter: to: self; setNameTo: 'SearchPane'; setBalloonText: 'Type here and all entries that match will be shown.' translated; vResizing: #shrinkWrap; hResizing: #spaceFill; margins: 4@6; backgroundColor: Color white. ^ aTextMorph! ! !ObjectsTool methodsFor: 'search' stamp: 'sw 6/30/2001 14:26'! searchPaneCharacter: evt "A character represented by the event handed in was typed in the search pane by the user" ^ self showMorphsMatchingSearchString " | char | *** The variant below only does a new search if RETURN or ENTER is hit *** char _ evt keyCharacter. (char == Character enter or: [char == Character cr]) ifTrue: [self showMorphsMatchingSearchString]"! ! !ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 10:39'! setSearchStringFromSearchPane "Set the search string by obtaining its contents from the search pane, and doing a certain amount of munging" searchString _ self searchPane text string asLowercase withBlanksTrimmed. searchString _ searchString copyWithoutAll: {Character enter. Character cr}! ! !ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 13:51'! showMorphsMatchingSearchString "Put items matching the search string into my lower pane" | quads | self setSearchStringFromSearchPane. self partsBin removeAllMorphs. Cursor wait showWhile: [quads := OrderedCollection new. Morph withAllSubclasses do: [:aClass | aClass addPartsDescriptorQuadsTo: quads if: [:info | info formalName translated includesSubstring: searchString caseSensitive: false]]. self installQuads: quads fromButton: nil]! ! !ObjectsTool methodsFor: 'search' stamp: 'nk 9/3/2004 12:13'! showSearchPane "Set the receiver up so that it shows the search pane" | tabsPane aPane frame | modeSymbol == #search ifTrue: [ ^self ]. self partsBin removeAllMorphs. tabsPane := self tabsPane. aPane _ self newSearchPane. aPane layoutChanged; fullBounds. aPane layoutFrame: (frame := tabsPane layoutFrame copy). frame bottomOffset: (frame topOffset + aPane height). self replaceSubmorph: tabsPane by: aPane. self partsBin layoutFrame topOffset: frame bottomOffset. self modeSymbol: #search. self showMorphsMatchingSearchString. ActiveHand newKeyboardFocus: aPane! ! !ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:06'! buttonPane "Answer the receiver's button pane, nil if none" ^ self submorphNamed: 'ButtonPane' ifNone: [].! ! !ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:09'! partsBin ^self findDeeplyA: PartsBin.! ! !ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 10:40'! searchPane "Answer the receiver's search pane, nil if none" ^ self submorphNamed: 'SearchPane' ifNone: [].! ! !ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 13:51'! showAlphabeticCategory: aString fromButton: aButton "Blast items beginning with a given letter into my lower pane" | eligibleClasses quads uc | self partsBin removeAllMorphs. uc := aString asUppercase asCharacter. Cursor wait showWhile: [eligibleClasses := Morph withAllSubclasses. quads := OrderedCollection new. eligibleClasses do: [:aClass | aClass theNonMetaClass addPartsDescriptorQuadsTo: quads if: [:info | info formalName translated asUppercase first = uc]]. self installQuads: quads fromButton: aButton]! ! !ObjectsTool methodsFor: 'submorph access' stamp: 'nk 9/3/2004 08:06'! tabsPane "Answer the receiver's tabs pane, nil if none" ^ self submorphNamed: 'TabPane' ifNone: [].! ! !ObjectsTool methodsFor: 'tabs' stamp: 'nk 9/3/2004 13:47'! initializeWithTabs: tabList "Initialize the receiver to have the given tabs" | oldPane newPane | oldPane := self tabsPane ifNil: [ self searchPane ]. newPane := (self paneForTabs: tabList) setNameTo: 'TabPane'; yourself. newPane layoutFrame: oldPane layoutFrame. self replaceSubmorph: oldPane by: newPane. newPane layoutChanged; fullBounds. self fixLayoutFrames. ! ! !ObjectsTool methodsFor: 'tabs' stamp: 'nk 9/3/2004 11:29'! paneForTabs: tabList "Answer a pane bearing tabs for the given list" | aPane | tabList do: [:t | t color: Color transparent. t borderWidth: 1; borderColor: Color black]. aPane := AlignmentMorph newRow listDirection: #leftToRight; wrapDirection: #topToBottom; vResizing: #spaceFill; hResizing: #spaceFill; cellInset: 6; layoutInset: 4; listCentering: #center; listSpacing: #equal; addAllMorphs: tabList; yourself. aPane width: self layoutBounds width. ^ aPane! ! !ObjectsTool methodsFor: 'tabs' stamp: 'dgd 8/30/2003 16:09'! presentHelp "Sent when a Help button is hit; provide the user with some form of help for the tool at hand" 'The Objects tool allows you to browse through, and obtain copies of, many kinds of objects. You can obtain an Objects tool by choosing "Objects" from the world menu, or by the shortcut of typing alt-o (cmd-o) any time the cursor is over the desktop. There are three ways to use Objects, corresponding to the three tabs seen at the top: alphabetic - gives you separate tabs for a, b, c, etc. Click any tab, and you will see the icons of all the objects whose names begin with that letter search - gives you a type-in pane for a search string. Type any letters there, and icons of all the objects whose names match what you have typed will appear in the bottom pane. categories - provides tabs representing categories of related items. Click on any tab to see the icons of all the objects in the category. When the cursor lingers over the icon of any object, you will get balloon help for the item. When you drag an icon from Objects, it will result in a new copy of it in your hand; the new object will be deposited wherever you next click.' translated openInWorkspaceWithTitle: 'About Objects' translated! ! !ObjectsTool commentStamp: '<historical>' prior: 0! I am a Master Parts Bin that allows the user to drag out a new Morph from a voluminous iconic list. Choose "objects" from the world menu, or type Alt-o (Cmd-o on the Mac). To add a new kinds of Morphs: In the class of the Morph, implement the message: descriptionForPartsBin ^ self partName: 'Rectangle' categories: #('Graphics' ' Basic 1 ') documentation: 'A rectangular shape, with border and fill style' The partName is the title that will show in the lower pane of the Object Tool. When is categories mode, an object can be seen in more than one category. The list above tells which ones. Documentation is what will show in the balloon help for each object thumbnail. The message #initializeToStandAlone creates the actual instance. To make a second variant object prototype coming from the same class, implement #supplementaryPartsDescriptions. In it, you get to specify the nativitySelector. It is sent to the class to get the variant objects. Often it is #authoringPrototype. (A class may supply supplementaryPartsDescriptions without implementing descriptionForPartsBin. This gives you better control.) ! !ObjectsTool class methodsFor: 'parts bin' stamp: 'sw 8/11/2001 20:16'! descriptionForPartsBin ^ self partName: 'Objects' categories: #('Useful') documentation: 'A place to obtain many kinds of objects'! ! !ObjectsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:45'! initialize self registerInFlapsRegistry. ! ! !ObjectsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:47'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ObjectsTool newStandAlone 'Object Catalog' 'A tool that lets you browse the catalog of objects') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(ObjectsTool newStandAlone 'Object Catalog' 'A tool that lets you browse the catalog of objects') forFlapNamed: 'Widgets'.]! ! !ObjectsTool class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:37'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !OldSimpleClientSocket class methodsFor: 'net news example' stamp: 'mir 5/13/2003 10:45'! nntpTest "SimpleClientSocket nntpTest" | addr s headers msgs header allNewsGroups | addr _ NetNameResolver promptUserForHostAddress. s _ OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: addr port: 119. "119 is the NNTP port number" s waitForConnectionUntil: self standardDeadline. Transcript show: s getResponse. s sendCommand: 'group comp.lang.smalltalk'. Transcript show: s getResponse. "get all the message headers for the current newsgroup" s sendCommand: 'xover 1-1000000'. headers _ s getMultilineResponseShowing: true. "print the headers of the first 10 messages of comp.lang.smalltalk" s sendCommand: 'listgroup comp.lang.smalltalk'. msgs _ self parseIntegerList: s getMultilineResponse. msgs ifNotNil: [ 1 to: 5 do: [:i | s sendCommand: 'head ', (msgs at: i) printString. header _ s getMultilineResponse. Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr]]. "get a full list of usenet newsgroups" s sendCommand: 'newgroups 010101 000000'. allNewsGroups _ s getMultilineResponse. Transcript show: allNewsGroups size printString, ' bytes in full newsgroup list'; cr. Transcript show: 'Sending quit...'; cr. s sendCommand: 'QUIT'. Transcript show: s getResponse. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. (headers ~~ nil and: [self confirm: 'show article headers from comp.lang.smalltalk?']) ifTrue: [ (StringHolder new contents: (self parseHeaderList: headers)) openLabel: 'Newsgroup Headers']. (allNewsGroups ~~ nil and: [self confirm: 'show list of all newsgroups available on your server?']) ifTrue: [ (StringHolder new contents: allNewsGroups) openLabel: 'All Usenet Newsgroups']. ! ! !OldSimpleClientSocket class methodsFor: 'POP mail example' stamp: 'mir 5/13/2003 10:45'! popTest "SimpleClientSocket popTest" | addr userName userPassword s msgs header | addr _ NetNameResolver promptUserForHostAddress. userName _ FillInTheBlank request: 'What is your email name?' initialAnswer: 'johnm'. userPassword _ FillInTheBlank request: 'What is your email password?'. s _ OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: addr port: 110. "110 is the POP3 port number" s waitForConnectionUntil: self standardDeadline. Transcript show: s getResponse. s sendCommand: 'USER ', userName. Transcript show: s getResponse. s sendCommand: 'PASS ', userPassword. Transcript show: s getResponse. s sendCommand: 'LIST'. "the following should be tweaked to handle an empy mailbox:" msgs _ self parseIntegerList: s getMultilineResponse. 1 to: (msgs size min: 5) do: [ :i | s sendCommand: 'TOP ', (msgs at: i) printString, ' 0'. header _ s getMultilineResponse. Transcript show: (self extractDateFromAndSubjectFromHeader: header); cr]. msgs size > 0 ifTrue: [ "get the first message" s sendCommand: 'RETR 1'. Transcript show: s getMultilineResponse]. Transcript show: 'closing connection'; cr. s sendCommand: 'QUIT'. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. ! ! !OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'! forkingRemoteCursorSender "This is the client side of a test that sends samples of the local input sensor state to the server, which may be running on a local or remote host. This method opens the connection, then forks a process to send the cursor data. Data is sent continuously until the user clicks in a 20x20 pixel square at the top-left corner of the display. The server should be started first. Note the server's address, since this method will prompt you for it." "SimpleClientSocket forkingRemoteCursorSender" | sock addr stopRect | Transcript show: 'starting remote cursor sender'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. addr _ NetNameResolver promptUserForHostAddress. Transcript show: 'opening connection'; cr. sock _ OldSimpleClientSocket new. sock connectTo: addr port: 54323. sock waitForConnectionUntil: self standardDeadline. (sock isConnected) ifFalse: [self error: 'sock not connected']. Transcript show: 'connection established'; cr. stopRect _ 0@0 corner: 20@20. "click in this rectangle to stop sending" Display reverse: stopRect. ["the sending process" [(stopRect containsPoint: Sensor cursorPoint) and: [Sensor anyButtonPressed]] whileFalse: [ sock sendCommand: self sensorStateString. (Delay forMilliseconds: 20) wait]. sock waitForSendDoneUntil: self standardDeadline. sock destroy. Transcript show: 'remote cursor sender done'; cr. Display reverse: stopRect. ] fork. ! ! !OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'! remoteCursorReceiver "Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it." "[SimpleClientSocket remoteCursorReceiver] fork" | sock response | Transcript show: 'starting remote cursor receiver'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. Transcript show: 'my address is ', NetNameResolver localAddressString; cr. Transcript show: 'opening connection'; cr. sock _ OldSimpleClientSocket new. sock listenOn: 54323. sock waitForConnectionUntil: (Socket deadlineSecs: 60). sock isConnected ifFalse: [ sock destroy. Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'. ^ self]. Transcript show: 'connection established'; cr. [sock isConnected] whileTrue: [ sock dataAvailable ifTrue: [ response _ sock getResponse. response displayOn: Display at: 10@10] ifFalse: [ "if no data available, let other processes run for a while" (Delay forMilliseconds: 20) wait]]. sock destroy. Transcript show: 'remote cursor receiver done'; cr. ! ! !OldSimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'mir 5/13/2003 10:45'! remoteCursorTest "This version of the remote cursor test runs both the client and the server code in the same loop." "SimpleClientSocket remoteCursorTest" | sock1 sock2 samplesToSend samplesSent done t | Transcript show: 'starting remote cursor test'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. Transcript show: 'opening connection'; cr. sock1 _ OldSimpleClientSocket new. sock2 _ OldSimpleClientSocket new. sock1 listenOn: 54321. sock2 connectTo: (NetNameResolver localHostAddress) port: 54321. sock1 waitForConnectionUntil: self standardDeadline. sock2 waitForConnectionUntil: self standardDeadline. (sock1 isConnected) ifFalse: [self error: 'sock1 not connected']. (sock2 isConnected) ifFalse: [self error: 'sock2 not connected']. Transcript show: 'connection established'; cr. samplesToSend _ 100. t _ Time millisecondsToRun: [ samplesSent _ 0. done _ false. [done] whileFalse: [ (sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [ sock1 sendCommand: self sensorStateString. samplesSent _ samplesSent + 1]. sock2 dataAvailable ifTrue: [ sock2 getResponse displayOn: Display at: 10@10]. done _ samplesSent = samplesToSend]]. sock1 destroy. sock2 destroy. Transcript show: 'remote cursor test done'; cr. Transcript show: samplesSent printString, ' samples sent in ', t printString, ' milliseconds'; cr. Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr. ! ! !OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'! finger: userName "OldSimpleClientSocket finger: 'stp'" | addr s | addr _ NetNameResolver promptUserForHostAddress. s _ OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: addr port: 79. "finger port number" s waitForConnectionUntil: self standardDeadline. s sendCommand: userName. Transcript show: s getResponse. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. ! ! !OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'! httpTestHost: hostName port: port url: url "This test fetches a URL from the given host and port." "SimpleClientSocket httpTestHost: 'www.disney.com' port: 80 url: '/'" "Tests URL fetch through a local HTTP proxie server: (SimpleClientSocket httpTestHost: '127.0.0.1' port: 8080 url: 'HTTP://www.exploratorium.edu/index.html')" | hostAddr s result buf bytes totalBytes t | Transcript cr; show: 'starting http test'; cr. Socket initializeNetwork. hostAddr _ NetNameResolver addressForName: hostName timeout: 10. hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName]. s _ OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: hostAddr port: port. s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 10). (s isConnected) ifFalse: [ s destroy. ^ self inform: 'could not connect']. Transcript show: 'connection open; waiting for data'; cr. s sendCommand: 'GET ', url, ' HTTP/1.0'. s sendCommand: 'User-Agent: Squeak 1.19'. s sendCommand: 'ACCEPT: text/html'. "always accept plain text" s sendCommand: 'ACCEPT: application/octet-stream'. "also accept binary data" s sendCommand: ''. "blank line" result _ WriteStream on: (String new: 10000). buf _ String new: 10000. totalBytes _ 0. t _ Time millisecondsToRun: [ [s isConnected] whileTrue: [ s waitForDataUntil: (Socket deadlineSecs: 5). bytes _ s receiveDataInto: buf. 1 to: bytes do: [:i | result nextPut: (buf at: i)]. totalBytes _ totalBytes + bytes. Transcript show: totalBytes printString, ' bytes received'; cr]]. s destroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '. Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr. Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr. Transcript endEntry. (StringHolder new contents: (result contents)) openLabel: 'HTTP Test Result: URL Contents'. ! ! !OldSimpleClientSocket class methodsFor: 'other examples' stamp: 'mir 5/13/2003 10:45'! timeTest "SimpleClientSocket timeTest" | addr s | addr _ NetNameResolver promptUserForHostAddress. s _ OldSimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: addr port: 13. "time port number" s waitForConnectionUntil: self standardDeadline. Transcript show: s getResponse. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. ! ! !OldSocket methodsFor: 'accessing' stamp: 'nk 2/24/2005 14:37'! localAddress self waitForConnectionUntil: self class standardDeadline. self isConnected ifFalse: [^ByteArray new: 4]. ^self primSocketLocalAddress: socketHandle! ! !OldSocket methodsFor: 'accessing' stamp: 'nk 2/24/2005 14:37'! localPort self waitForConnectionUntil: self class standardDeadline. self isConnected ifFalse: [^0]. ^self primSocketLocalPort: socketHandle! ! !OldSocket methodsFor: 'connection open/close' stamp: 'nk 2/24/2005 14:37'! accept "Accept a connection from the receiver socket. Return a new socket that is connected to the client" ^self class acceptFrom: self! ! !OldSocket methodsFor: 'connection open/close' stamp: 'nk 2/24/2005 14:37'! closeAndDestroy: timeoutSeconds "First, try to close this connection gracefully. If the close attempt fails or times out, abort the connection. In either case, destroy the socket. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." socketHandle = nil ifFalse: [self isConnected ifTrue: [self close. "close this end" (self waitForDisconnectionUntil: (self class deadlineSecs: timeoutSeconds)) ifFalse: ["if the other end doesn't close soon, just abort the connection" self primSocketAbortConnection: socketHandle]]. self destroy]! ! !OldSocket methodsFor: 'connection open/close' stamp: 'ikp 9/1/2003 20:47'! listenOn: portNumber backlogSize: backlog interface: ifAddr "Listen for a connection on the given port. If this method succeeds, #accept may be used to establish a new connection" | status | status _ self primSocketConnectionStatus: socketHandle. (status == Unconnected) ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection']. self primSocket: socketHandle listenOn: portNumber backlogSize: backlog interface: ifAddr. ! ! !OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'! getData "Get some data" | buf bytesRead | (self waitForDataUntil: self class standardDeadline) ifFalse: [self error: 'getData timeout']. buf := String new: 4000. bytesRead := self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. ^buf copyFrom: 1 to: bytesRead! ! !OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'! readInto: aStringOrByteArray startingAt: aNumber "Read data into the given buffer starting at the given index and return the number of bytes received. Note the given buffer may be only partially filled by the received data." (self waitForDataUntil: self class standardDeadline) ifFalse: [self error: 'receive timeout']. ^self primSocket: socketHandle receiveDataInto: aStringOrByteArray startingAt: aNumber count: aStringOrByteArray size - aNumber + 1! ! !OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'! sendData: aStringOrByteArray "Send all of the data in the given array, even if it requires multiple calls to send it all. Return the number of bytes sent." "An experimental version use on slow lines: Longer timeout and smaller writes to try to avoid spurious timeouts." | bytesSent bytesToSend count | bytesToSend := aStringOrByteArray size. bytesSent := 0. [bytesSent < bytesToSend] whileTrue: [(self waitForSendDoneUntil: (self class deadlineSecs: 60)) ifFalse: [self error: 'send data timeout; data not sent']. count := self primSocket: socketHandle sendData: aStringOrByteArray startIndex: bytesSent + 1 count: (bytesToSend - bytesSent min: 5000). bytesSent := bytesSent + count]. ^bytesSent! ! !OldSocket methodsFor: 'sending-receiving' stamp: 'nk 2/24/2005 14:37'! sendSomeData: aStringOrByteArray startIndex: startIndex count: count "Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent." "Note: This operation may have to be repeated multiple times to send a large amount of data." | bytesSent | (self waitForSendDoneUntil: (self class deadlineSecs: 20)) ifTrue: [bytesSent := self primSocket: socketHandle sendData: aStringOrByteArray startIndex: startIndex count: count] ifFalse: [self error: 'send data timeout; data not sent']. ^bytesSent! ! !OldSocket methodsFor: 'primitives' stamp: 'ikp 9/1/2003 20:55'! primSocket: aHandle listenOn: portNumber backlogSize: backlog interface: ifAddr "Primitive. Set up the socket to listen on the given port. Will be used in conjunction with #accept only." <primitive: 'primitiveSocketListenOnPortBacklogInterface' module: 'SocketPlugin'> self destroy. "Accept not supported so clean up"! ! !OldSocket methodsFor: 'datagrams' stamp: 'nk 2/24/2005 14:37'! sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber "Send a UDP packet containing the given data to the specified host/port." | bytesToSend bytesSent count | bytesToSend := aStringOrByteArray size. bytesSent := 0. [bytesSent < bytesToSend] whileTrue: [(self waitForSendDoneUntil: (self class deadlineSecs: 20)) ifFalse: [self error: 'send data timeout; data not sent']. count := self primSocket: socketHandle sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: bytesSent + 1 count: bytesToSend - bytesSent. bytesSent := bytesSent + count]. ^bytesSent! ! !OldSocket methodsFor: 'other' stamp: 'nk 2/24/2005 14:37'! getResponseNoLF "Get the response to the last command." | buf response bytesRead c lf | (self waitForDataUntil: (self class deadlineSecs: 20)) ifFalse: [self error: 'getResponse timeout']. lf := Character lf. buf := String new: 1000. response := WriteStream on: ''. [self dataAvailable] whileTrue: [bytesRead := self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. 1 to: bytesRead do: [:i | (c := buf at: i) ~= lf ifTrue: [response nextPut: c]]]. ^response contents! ! !OldSocket class methodsFor: 'class initialization' stamp: 'ar 12/12/2001 19:12'! initialize "Socket initialize" "Socket Types" TCPSocketType _ 0. UDPSocketType _ 1. "Socket Status Values" InvalidSocket _ -1. Unconnected _ 0. WaitingForConnection _ 1. Connected _ 2. OtherEndClosed _ 3. ThisEndClosed _ 4. RegistryThreshold _ 100. "# of sockets"! ! !OldSocket class methodsFor: 'network initialization' stamp: 'nk 2/24/2005 14:38'! ensureNetworkConnected "Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection." "Socket ensureNetworkConnected" self initializeNetwork. Utilities informUser: 'Contacting domain name server...' during: [NetNameResolver addressForName: 'bogusNameToForceDNSToBeConsulted.org' timeout: 30]! ! !OldSocket class methodsFor: 'network initialization' stamp: 'mir 11/14/2002 19:36'! initializeNetwork "Initialize the network drivers and the NetNameResolver. Do nothing if the network is already initialized." "Note: The network must be re-initialized every time Squeak starts up, so applications that persist across snapshots should be prepared to re-initialize the network as needed. Such applications should call 'Socket initializeNetwork' before every network transaction. " NetNameResolver initializeNetwork! ! !OldSocket class methodsFor: 'network initialization' stamp: 'mir 11/14/2002 19:36'! initializeNetworkIfFail: failBlock "Initialize the network drivers. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails, perhaps because this computer isn't currently connected to a network." NetNameResolver initializeNetwork! ! !OldSocket class methodsFor: 'tests' stamp: 'nk 2/24/2005 14:38'! loopbackTest "Send data from one socket to another on the local machine. Tests most of the socket primitives." "100 timesRepeat: [Socket loopbackTest]" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead | Transcript cr; show: 'starting loopback test'; cr. Transcript show: '---------- Connecting ----------'; cr. self initializeNetwork. sock1 := self new. sock2 := self new. sock1 listenOn: 54321. sock2 connectTo: NetNameResolver localHostAddress port: 54321. sock1 waitForConnectionUntil: self standardDeadline. sock2 waitForConnectionUntil: self standardDeadline. sock1 isConnected ifFalse: [self error: 'sock1 not connected']. sock2 isConnected ifFalse: [self error: 'sock2 not connected']. Transcript show: 'connection established'; cr. bytesToSend := 5000000. sendBuf := String new: 5000 withAll: $x. receiveBuf := String new: 50000. done := false. packetsSent := packetsRead := bytesSent := bytesReceived := 0. t := Time millisecondsToRun: [[done] whileFalse: [(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (sock1 sendSomeData: sendBuf)]. sock2 dataAvailable ifTrue: [packetsRead := packetsRead + 1. bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)]. done := bytesSent >= bytesToSend and: [bytesReceived = bytesSent]]]. Transcript show: 'closing connection'; cr. sock1 waitForSendDoneUntil: self standardDeadline. sock1 close. sock2 waitForDisconnectionUntil: self standardDeadline. extraBytes := sock2 discardReceivedData. extraBytes > 0 ifTrue: [Transcript show: ' *** received ' , extraBytes size printString , ' extra bytes ***'; cr]. sock2 close. sock1 waitForDisconnectionUntil: self standardDeadline. sock1 isUnconnectedOrInvalid ifFalse: [self error: 'sock1 not closed']. sock2 isUnconnectedOrInvalid ifFalse: [self error: 'sock2 not closed']. Transcript show: '---------- Connection Closed ----------'; cr. sock1 destroy. sock2 destroy. Transcript show: 'loopback test done; time = ' , t printString; cr. Transcript show: (bytesToSend asFloat / t roundTo: 0.01) printString , ' 1000Bytes/sec'; cr. Transcript endEntry! ! !OldSocket class methodsFor: 'tests' stamp: 'nk 2/24/2005 14:38'! sendTest "Send data to the 'discard' socket of the given host. Tests the speed of one-way data transfers across the network to the given host. Note that many host hosts do not run a discard server." "Socket sendTest" | sock bytesToSend sendBuf bytesSent t serverName serverAddr | Transcript cr; show: 'starting send test'; cr. self initializeNetwork. serverName := FillInTheBlank request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'. serverAddr := NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [^self inform: 'Could not find an address for ' , serverName]. sock := self new. Transcript show: '---------- Connecting ----------'; cr. sock connectTo: serverAddr port: 9. sock waitForConnectionUntil: self standardDeadline. sock isConnected ifFalse: [sock destroy. ^self inform: 'could not connect']. Transcript show: 'connection established; sending data'; cr. bytesToSend := 1000000. sendBuf := String new: 64 * 1024 withAll: $x. bytesSent := 0. t := Time millisecondsToRun: [[bytesSent < bytesToSend] whileTrue: [sock sendDone ifTrue: [bytesSent := bytesSent + (sock sendSomeData: sendBuf)]]]. sock waitForSendDoneUntil: self standardDeadline. sock destroy. Transcript show: '---------- Connection Closed ----------'; cr. Transcript show: 'send test done; time = ' , t printString; cr. Transcript show: (bytesToSend asFloat / t roundTo: 0.01) printString , ' 1000Bytes/sec'; cr. Transcript endEntry! ! !OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'! ping: hostName "Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server." "Socket ping: 'squeak.cs.uiuc.edu'" | tcpPort sock serverAddr startTime echoTime | tcpPort := 7. "7 = echo port, 13 = time port, 19 = character generator port" self initializeNetwork. serverAddr := NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [^self inform: 'Could not find an address for ' , hostName]. sock := self new. sock connectTo: serverAddr port: tcpPort. [sock waitForConnectionUntil: (self deadlineSecs: 10). sock isConnected] whileFalse: [(self confirm: 'Continue to wait for connection to ' , hostName , '?') ifFalse: [sock destroy. ^self]]. sock sendData: 'echo!!'. startTime := Time millisecondClockValue. [sock waitForDataUntil: (self deadlineSecs: 15). sock dataAvailable] whileFalse: [(self confirm: 'Packet sent but no echo yet; keep waiting?') ifFalse: [sock destroy. ^self]]. echoTime := Time millisecondClockValue - startTime. sock destroy. self inform: hostName , ' responded in ' , echoTime printString , ' milliseconds'! ! !OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'! pingPorts: portList on: hostName timeOutSecs: timeOutSecs "Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports." "Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15" | serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result | self initializeNetwork. serverAddr := NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [self inform: 'Could not find an address for ' , hostName. ^#()]. sockets := portList collect: [:portNum | sock := self new. sock connectTo: serverAddr port: portNum]. deadline := self deadlineSecs: timeOutSecs. done := false. [done] whileFalse: [unconnectedCount := 0. connectedCount := 0. waitingCount := 0. sockets do: [:s | s isUnconnectedOrInvalid ifTrue: [unconnectedCount := unconnectedCount + 1] ifFalse: [s isConnected ifTrue: [connectedCount := connectedCount + 1]. s isWaitingForConnection ifTrue: [waitingCount := waitingCount + 1]]]. waitingCount = 0 ifTrue: [done := true]. connectedCount = sockets size ifTrue: [done := true]. Time millisecondClockValue > deadline ifTrue: [done := true]]. result := (sockets select: [:s | s isConnected]) collect: [:s | self nameForWellKnownTCPPort: s remotePort]. sockets do: [:s | s destroy]. ^result! ! !OldSocket class methodsFor: 'utilities' stamp: 'nk 2/24/2005 14:38'! pingPortsOn: hostName "Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports." "Socket pingPortsOn: 'www.disney.com'" ^self pingPorts: #(7 13 19 21 23 25 80 110 119) on: hostName timeOutSecs: 20! ! !OldSocket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'! registryThreshold "Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails." ^RegistryThreshold! ! !OldSocket class methodsFor: 'registry' stamp: 'ar 12/12/2001 19:12'! registryThreshold: aNumber "Return the registry threshold above which socket creation may fail due to too many already open sockets. If the threshold is reached, a full GC will be issued if the creation of a socket fails." RegistryThreshold _ aNumber! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! clientServerTestUDP "Socket clientServerTestUDP" "Performa 6400/200, Linux-PPC 2.1.24: client/server UDP test done; time = 2820 2500 packets, 10000000 bytes sent (3546 kBytes/sec) 2500 packets, 10000000 bytes received (3546 kBytes/sec) 4000 bytes/packet, 886 packets/sec, 0 packets dropped" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. Transcript show: 'creating endpoints'; cr. sock1 := self newUDP. "the sender" sock2 := self newUDP. "the recipient" sock2 setPort: 54321. sock1 setPeer: NetNameResolver localHostAddress port: sock2 port. Transcript show: 'endpoints created'; cr. bytesToSend := 10000000. sendBuf := String new: 4000 withAll: $x. receiveBuf := String new: 50000. done := false. bytesSent := bytesReceived := packetsSent := packetsReceived := 0. t := Time millisecondsToRun: [[done] whileFalse: [(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (sock1 sendData: sendBuf)]. sock2 dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. bytesReceived := bytesReceived + (sock2 receiveDataInto: receiveBuf)]. done := bytesSent >= bytesToSend]. sock1 waitForSendDoneUntil: self standardDeadline. bytesReceived := bytesReceived + sock2 discardReceivedData]. Transcript show: 'closing endpoints'; cr. sock1 close. sock2 close. sock1 destroy. sock2 destroy. Transcript show: 'client/server UDP test done; time = ' , t printString; cr. Transcript show: packetsSent printString , ' packets, ' , bytesSent printString , ' bytes sent (' , (bytesSent * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: packetsReceived printString , ' packets, ' , bytesReceived printString , ' bytes received (' , (bytesReceived * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString , ' bytes/packet, ' , (packetsReceived * 1000 // t) printString , ' packets/sec, ' , (packetsSent - packetsReceived) printString , ' packets dropped'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! clientServerTestUDP2 "Socket clientServerTestUDP2" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t datagramInfo | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. Transcript show: 'creating endpoints'; cr. sock1 := self newUDP. "the sender" sock2 := self newUDP. "the recipient" sock2 setPort: 54321. Transcript show: 'endpoints created'; cr. bytesToSend := 100000000. sendBuf := String new: 4000 withAll: $x. receiveBuf := String new: 2000. done := false. bytesSent := bytesReceived := packetsSent := packetsReceived := 0. t := Time millisecondsToRun: [[done] whileFalse: [(sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (sock1 sendData: sendBuf toHost: NetNameResolver localHostAddress port: sock2 port)]. sock2 dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. datagramInfo := sock2 receiveUDPDataInto: receiveBuf. bytesReceived := bytesReceived + (datagramInfo at: 1)]. done := bytesSent >= bytesToSend]. sock1 waitForSendDoneUntil: self standardDeadline. bytesReceived := bytesReceived + sock2 discardReceivedData]. Transcript show: 'closing endpoints'; cr. sock1 close. sock2 close. sock1 destroy. sock2 destroy. Transcript show: 'client/server UDP test done; time = ' , t printString; cr. Transcript show: packetsSent printString , ' packets, ' , bytesSent printString , ' bytes sent (' , (bytesSent * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: packetsReceived printString , ' packets, ' , bytesReceived printString , ' bytes received (' , (bytesReceived * 1000 // t) printString , ' Bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString , ' bytes/packet, ' , (packetsReceived * 1000 // t) printString , ' packets/sec, ' , (packetsSent - packetsReceived) printString , ' packets dropped'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestClientTCP "FIRST start up another image, and execute: Socket remoteTestServerTCP. THEN come back to this image and execute:" "Socket remoteTestClientTCP" "Performa 6400/200, Linux-PPC 2.1.24, both images on same CPU: remoteClient TCP test done; time = 5680 250 packets, 1000000 bytes sent (176 kBytes/sec) 60 packets, 1000000 bytes received (176 kBytes/sec)" | socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. socket := self newTCP. serverName := FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: self standardDeadline. Transcript show: 'client endpoint created'; cr. bytesToSend := 1000000. sendBuf := String new: 4000 withAll: $x. receiveBuf := String new: 50000. done := false. bytesSent := bytesReceived := packetsSent := packetsReceived := 0. t := Time millisecondsToRun: [[done] whileFalse: [(socket sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (socket sendData: sendBuf)]. socket dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]. done := bytesSent >= bytesToSend]. [bytesReceived < bytesToSend] whileTrue: [socket dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]]]. socket closeAndDestroy. Transcript show: 'remoteClient TCP test done; time = ' , t printString; cr. Transcript show: packetsSent printString , ' packets, ' , bytesSent printString , ' bytes sent (' , (bytesSent * 1000 // t) printString , ' bytes/sec)'; cr. Transcript show: packetsReceived printString , ' packets, ' , bytesReceived printString , ' bytes received (' , (bytesReceived * 1000 // t) printString , ' bytes/sec)'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestClientTCPOpenClose1000 "Socket remoteTestClientTCPOpenClose1000" | number t1 socket serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. number := 1000. serverName := FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. t1 := Time millisecondsToRun: [number timesRepeat: [socket := self newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: self standardDeadline. socket closeAndDestroy]]. Transcript cr; show: 'connects/close per second ' , (number / t1 * 1000.0) printString; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestClientTCPOpenClosePutGet "Socket remoteTestClientTCPOpenClosePutGet" | checkLength number bytesExpected sendBuf receiveBuf t1 socket bytesReceived serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. number := 1000. bytesExpected := 20000. sendBuf := String new: 80 withAll: $x. receiveBuf := String new: 50000. t1 := Time millisecondsToRun: [number timesRepeat: [socket := self newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: self standardDeadline. socket sendData: sendBuf. socket waitForSendDoneUntil: (self deadlineSecs: 5). socket waitForDataUntil: (self deadlineSecs: 5). bytesReceived := 0. [bytesReceived < bytesExpected] whileTrue: [checkLength := socket receiveDataInto: receiveBuf. bytesReceived := bytesReceived + checkLength]. socket closeAndDestroy]]. Transcript cr; show: 'connects/get/put/close per second ' , (number / t1 * 1000.0) printString; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestClientUDP "FIRST start up another image, and execute: Socket remoteTestServerUDP. THEN come back to this image and execute:" "Socket remoteTestClientUDP" "Performa 6400/200, Linux-PPC 2.1.24: remoteClient UDP test done; time = 4580 2500 packets, 10000000 bytes sent (2183 kBytes/sec) 180 packets, 720000 bytes received (157 kBytes/sec) 4000 bytes/packet, 39 packets/sec, 2320 packets dropped" | socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. socket := self newUDP. socket setPeer: (NetNameResolver addressFromString: serverName) port: 54321. Transcript show: 'client endpoint created'; cr. bytesToSend := 10000000. sendBuf := String new: 4000 withAll: $x. receiveBuf := String new: 4000. done := false. bytesSent := bytesReceived := packetsSent := packetsReceived := 0. t := Time millisecondsToRun: [[done] whileFalse: [(socket sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent := packetsSent + 1. bytesSent := bytesSent + (socket sendData: sendBuf)]. socket dataAvailable ifTrue: [packetsReceived := packetsReceived + 1. bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]. done := bytesSent >= bytesToSend]. [socket waitForDataUntil: (self deadlineSecs: 1). socket dataAvailable] whileTrue: [packetsReceived := packetsReceived + 1. bytesReceived := bytesReceived + (socket receiveDataInto: receiveBuf)]]. socket closeAndDestroy. Transcript show: 'remoteClient UDP test done; time = ' , t printString; cr. Transcript show: packetsSent printString , ' packets, ' , bytesSent printString , ' bytes sent (' , (bytesSent * 1000 // t) printString , ' bytes/sec)'; cr. Transcript show: packetsReceived printString , ' packets, ' , bytesReceived printString , ' bytes received (' , (bytesReceived * 1000 // t) printString , ' bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString , ' bytes/packet, ' , (packetsReceived * 1000 // t) printString , ' packets/sec, ' , (packetsSent - packetsReceived) printString , ' packets dropped'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerTCP "See remoteTestClientTCP for instructions on running this method." "OldSocket remoteTestServerTCP" | socket client buffer n | Transcript show: 'initializing network ... '. self initializeNetwork. Transcript show: 'ok'; cr. socket := OldSocket newTCP. socket listenOn: 54321 backlogSize: 5 interface: (NetNameResolver addressFromString: '127.0.0.1'). "or: 0.0.0.0" Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 4000. socket waitForConnectionUntil: self standardDeadline. client := socket accept. [client isConnected] whileTrue: [client dataAvailable ifTrue: [n := client receiveDataInto: buffer. client sendData: buffer count: n]]. client closeAndDestroy. socket closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr. ^socket! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerTCPOpenClose1000 "The version of #remoteTestServerTCPOpenClose1000 using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClose1000" | socket server | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. 1000 timesRepeat: [socket := server waitForAcceptUntil: (self deadlineSecs: 300). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerTCPOpenClosePutGet "The version of #remoteTestServerTCPOpenClosePutGet using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClosePutGet" | socket server bytesIWantToSend bytesExpected receiveBuf sendBuf checkLength | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. bytesIWantToSend := 20000. bytesExpected := 80. receiveBuf := String new: 40000. sendBuf := String new: bytesIWantToSend withAll: $x. 1000 timesRepeat: [socket := server waitForAcceptUntil: (self deadlineSecs: 300). socket waitForDataUntil: (self deadlineSecs: 5). checkLength := socket receiveDataInto: receiveBuf. checkLength ~= bytesExpected ifTrue: [self halt]. socket sendData: sendBuf. socket waitForSendDoneUntil: (self deadlineSecs: 5). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerTCPUsingAccept "The version of #remoteTestServer using the BSD style accept() mechanism." "Socket remoteTestServerTCPUsingAccept" | socket buffer n server | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. server := self newTCP. server listenOn: 54321 backlogSize: 4. server isValid ifFalse: [self error: 'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 40000. 10 timesRepeat: [socket := server waitForAcceptUntil: (self deadlineSecs: 300). [socket isConnected] whileTrue: [socket dataAvailable ifTrue: [n := socket receiveDataInto: buffer. socket sendData: buffer count: n]]]. socket closeAndDestroy. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerUDP "See remoteTestClientUDP for instructions on running this method." "Socket remoteTestServerUDP" | socket buffer n | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. socket := self newUDP. socket setPort: 54321. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 4000. [true] whileTrue: [socket dataAvailable ifTrue: [n := socket receiveDataInto: buffer. socket sendData: buffer count: n]]! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestServerUDP2 "See remoteTestClientUDP for instructions on running this method." "Socket remoteTestServerUDP2" | socket buffer datagramInfo | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. socket := self newUDP. socket setPort: 54321. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 65000. [true] whileTrue: [socket dataAvailable ifTrue: [datagramInfo := socket receiveUDPDataInto: buffer. Transcript show: datagramInfo printString; cr. socket sendData: buffer count: (datagramInfo at: 1)]]! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! remoteTestSinkTCP "See sendTest for instructions on running this method." "Socket remoteTestSinkTCP" | socket buffer n | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. socket := self newTCP. socket listenOn: 9. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer := String new: 64000. socket waitForConnectionUntil: self standardDeadline. [socket isConnected] whileTrue: [socket dataAvailable ifTrue: [n := socket receiveDataInto: buffer]]. socket closeAndDestroy. Transcript cr; show: 'sink endpoint destroyed'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:10'! timeTest "OldSocket timeTest" | serverName serverAddr s | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^Transcript show: 'never mind'; cr]. serverAddr := NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ' , serverName]. s := self new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: serverAddr port: 13. "13 is the 'daytime' port number" s waitForConnectionUntil: (self deadlineSecs: 1). Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! timeTestUDP "Socket timeTestUDP" | serverName serverAddr s | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^Transcript show: 'never mind'; cr]. serverAddr := NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ' , serverName]. s := self newUDP. "a 'random' port number will be allocated by the system" "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. "13 is the daytime service" Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! timeTestUDP2 "Socket timeTestUDP2" | serverName serverAddr s | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^Transcript show: 'never mind'; cr]. serverAddr := NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ' , serverName]. s := self newUDP. "The following associates a port with the UDP socket, but does NOT create a connectable endpoint" s setPort: 54321. "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr! ! !OldSocket class methodsFor: 'examples' stamp: 'nk 2/24/2005 14:38'! timeTestUDP3 "Socket timeTestUDP3" | serverName serverAddr s | Transcript show: 'initializing network ... '. self initializeNetworkIfFail: [^Transcript show: 'failed']. Transcript show: 'ok'; cr. serverName := FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^Transcript show: 'never mind'; cr]. serverAddr := NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ' , serverName]. s := self newUDP. "The following associates a port with the UDP socket, but does NOT create a connectable endpoint" s setPort: self wildcardPort. "explicitly request a default port number" "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr! ! !OrderedCollection methodsFor: 'adding' stamp: 'BG 1/9/2004 12:30'! add: newObject beforeIndex: index "Add the argument, newObject, as an element of the receiver. Put it in the sequence just before index. Answer newObject." self add: newObject afterIndex: index - 1. ^ newObject! ! !OrderedCollection methodsFor: 'adding' stamp: 'sw 3/1/2001 11:03'! addAllFirstUnlessAlreadyPresent: anOrderedCollection "Add each element of anOrderedCollection at the beginning of the receiver, preserving the order, but do not add any items that are already in the receiver. Answer anOrderedCollection." anOrderedCollection reverseDo: [:each | (self includes: each) ifFalse: [self addFirst: each]]. ^ anOrderedCollection! ! !OrderedCollection methodsFor: 'adding' stamp: 'ajh 5/22/2003 12:03'! at: index ifAbsentPut: block "Return value at index, however, if value does not exist (nil or out of bounds) then add block's value at index (growing self if necessary)" | v | index <= self size ifTrue: [ ^ (v _ self at: index) ifNotNil: [v] ifNil: [self at: index put: block value] ]. [self size < index] whileTrue: [self add: nil]. ^ self at: index put: block value! ! !OrderedCollection methodsFor: 'removing' stamp: 'raok 4/27/2001 15:35'! removeAllSuchThat: aBlock "Remove each element of the receiver for which aBlock evaluates to true. The method in Collection is O(N^2), this is O(N)." | n | n _ firstIndex. firstIndex to: lastIndex do: [:index | (aBlock value: (array at: index)) ifFalse: [ array at: n put: (array at: index). n _ n + 1]]. n to: lastIndex do: [:index | array at: index put: nil]. lastIndex _ n - 1! ! !OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:37'! removeFirst: n "Remove first n object into an array" | list | list _ Array new: n. 1 to: n do: [:i | list at: i put: self removeFirst]. ^ list! ! !OrderedCollection methodsFor: 'removing' stamp: 'ajh 6/22/2003 14:36'! removeLast: n "Remove last n object into an array with last in last position" | list | list _ Array new: n. n to: 1 by: -1 do: [:i | list at: i put: self removeLast]. ^ list! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:26'! find: oldObject " This method answers an index in the range firstIndex .. lastIndex, which is meant for internal use only. Never use this method in your code, the methods for public use are: #indexOf: #indexOf:ifAbsent: " | index | index _ firstIndex. [index <= lastIndex] whileTrue: [(array at: index) = oldObject ifTrue: [^ index]. index _ index + 1]. self errorNotFound: oldObject! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:29'! insert: anObject before: spot " spot is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. Never use this method in your code, it is meant for private use by OrderedCollection only. The methods for use are: #add:before: to insert an object before another object #add:beforeIndex: to insert an object before a given position. " | "index" delta spotIndex| spotIndex _ spot. delta _ spotIndex - firstIndex. firstIndex = 1 ifTrue: [self makeRoomAtFirst. spotIndex _ firstIndex + delta]. firstIndex _ firstIndex - 1. array replaceFrom: firstIndex to: spotIndex - 2 with: array startingAt: firstIndex + 1. array at: spotIndex - 1 put: anObject. " index _ firstIndex _ firstIndex - 1. [index < (spotIndex - 1)] whileTrue: [array at: index put: (array at: index + 1). index _ index + 1]. array at: index put: anObject." ^ anObject! ! !OrderedCollection methodsFor: 'private' stamp: 'BG 1/9/2004 12:28'! removeIndex: removedIndex " removedIndex is an index in the range firstIndex .. lastIndex, such an index is not known from outside the collection. Never use this method in your code, it is meant for private use by OrderedCollection only. The method for public use is: #removeAt: " array replaceFrom: removedIndex to: lastIndex - 1 with: array startingAt: removedIndex+1. array at: lastIndex put: nil. lastIndex _ lastIndex - 1.! ! !OrderedCollection methodsFor: 'inspecting' stamp: 'apb 7/14/2004 12:19'! inspectorClass "Answer the class of the inspector to be used on the receiver. Called by inspect; use basicInspect to get a normal (less useful) type of inspector." ^OrderedCollectionInspector! ! !OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'dew 9/19/2001 03:27'! fieldList object ifNil: [ ^ OrderedCollection new]. ^ self baseFieldList , (object size <= (self i1 + self i2) ifTrue: [(1 to: object size) collect: [:i | i printString]] ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) collect: [:i | i printString]]) " OrderedCollection new inspect (OrderedCollection newFrom: #(3 5 7 123)) inspect (OrderedCollection newFrom: (1 to: 1000)) inspect "! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'sd 1/10/2004 15:28'! testAddBefore "self run: #testAddBefore" | l | l := #(1 2 3 4) asOrderedCollection. l add: 88 before: 1. self assert: (l = #(88 1 2 3 4) asOrderedCollection). l add: 99 before: 2. self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). ! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 21:52'! testAddBeforeAndRemove "self run: #testAddBefore" | l initialCollection | l := #(1 2 3 4) asOrderedCollection. initialCollection := l shallowCopy. l add: 88 before: 1. self assert: (l = #(88 1 2 3 4) asOrderedCollection). l add: 99 before: 2. self assert: (l = #(88 1 99 2 3 4) asOrderedCollection). l remove: 99. l remove: 88. self assert: l = initialCollection. ! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 21:46'! testAddDuplicateItem1 | collection | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. collection add: 'John' before: 'John'. self assert: ((collection asBag occurrencesOf: 'John') = 2 and: [(collection at: (collection indexOf: 'John') + 1) = (collection at: (collection indexOf: 'John'))])! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 21:49'! testAddItem1 | collection size | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. size := collection size. collection add: 'James' before: 'Jim'. collection add: 'Margaret' before: 'Andrew'. self assert: size + 2 = collection size. ! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 21:50'! testAddItem2 | collection | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. collection add: 'James' before: 'Jim'. collection add: 'Margaret' before: 'Andrew'. self assert: (collection indexOf: 'James') + 1 = (collection indexOf: 'Jim'). self assert: (collection indexOf: 'Margaret') + 1 = (collection indexOf: 'Andrew').! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 21:55'! testIndexOf | collection indices | collection := #('Jim' 'Mary' 'John' 'Andrew' ) asOrderedCollection. indices := collection collect: [:item | collection indexOf: item]. self assert: (1 to: 4) asOrderedCollection = indices. " note that this assertion does not hold in the presence of duplicate items. " ! ! !OrderedCollectionTest methodsFor: 'testing-public methods' stamp: 'BG 1/10/2004 22:45'! testIndexOfWithDuplicates | collection indices bagOfIndices | collection := #('Jim' 'Mary' 'John' 'Andrew' 'Mary' 'John' 'Jim' 'Micheal') asOrderedCollection. indices := collection collect: [:item | collection indexOf: item]. self assert: indices asSet size = collection asSet size. bagOfIndices := indices asBag. self assert: (indices asSet allSatisfy: [:index | (bagOfIndices occurrencesOf: index) = (collection occurrencesOf: (collection at: index))]). " indexOf: returns the index of the first occurrence of an item. For an item with n occurrences, the index of its first occurrence is found n times. "! ! !OrderedCollectionTest commentStamp: 'BG 1/10/2004 22:07' prior: 0! These test cases demonstrate addition of items into an OrderedCollection as well as item removal. Some of the assertions are quite complicated and use a lot of collection protocol. Such methods do not test one single method, but protocol in general.! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:03'! direction ^direction ifNil:[direction _ normal y @ normal x negated]! ! !OrientedFillStyle methodsFor: 'Morphic menu' stamp: 'dgd 10/17/2003 22:35'! addFillStyleMenuItems: aMenu hand: aHand from: aMorph "Add the items for changing the current fill style of the receiver" aMenu add: 'change origin' translated target: self selector: #changeOriginIn:event: argument: aMorph. aMenu add: 'change orientation' translated target: self selector: #changeOrientationIn:event: argument: aMorph.! ! !OrientedFillStyle commentStamp: '<historical>' prior: 0! OrientedFill is an abstract superclass for fills which can be aligned appropriately. Instance variables: origin <Point> The point at which to align the fill. direction <Point> The direction in which the fill is defined normal <Point> Typically, just the direction rotated by 90 degrees.! !OutOfScopeNotification methodsFor: 'as yet unclassified' stamp: 'RAA 2/5/2001 10:41'! defaultAction self resume: false! ! !PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:30'! comment ^ '{prim disabled by ', self className, '} '! ! !PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! disabledPrimStartString ^ '"', self comment, self enabledPrimStartString! ! !PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! disabledPrimStopChar "end of disabling comment" ^ $"! ! !PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! enabledPrimStartString ^ '<primitive:'! ! !PCCByCompilation methodsFor: 'string constants' stamp: 'sr 6/7/2004 03:31'! enabledPrimStopChar ^ $>! ! !PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:33'! extractCallModuleNames: aMethodRef ^ (self existsCompiledCallIn: aMethodRef) ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef] ifFalse: [| src | "try source" "higher priority to avoid source file accessing errors" [src := aMethodRef sourceString] valueAt: self higherPriority. self extractCallNamesFromPrimString: ((self extractDisabledPrimStringFrom: src) ifNil: ["no disabled prim string found" ^ nil]) first]! ! !PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:38'! methodsWithCall "Expensive!! For just querying the system unaffected by an instance of this class use PCCByLiterals instead." ^ self methodsWithCompiledCall , self methodsWithDisabledCall! ! !PCCByCompilation methodsFor: 'ui querying' stamp: 'sr 6/15/2004 04:51'! methodsWithDisabledCall "Answer a SortedCollection of all the methods that contain, in source code, the substring indicating a disabled prim." "The alternative implementation ^ SystemNavigation new allMethodsWithSourceString: self disabledPrimStartString matchCase: true also searches in class comments." | list classCount string | string := self disabledPrimStartString. list := Set new. 'Searching all method source code...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size * 2 "classes with their metaclasses" during: [:bar | classCount := 0. SystemNavigation default allBehaviorsDo: [:class | bar value: (classCount := classCount + 1). class selectorsDo: [:sel | | src | "higher priority to avoid source file accessing errors" [src := class sourceCodeAt: sel] valueAt: self higherPriority. (src findString: string startingAt: 1 caseSensitive: true) > 0 ifTrue: [sel == #DoIt ifFalse: [list add: (MethodReference new setStandardClass: class methodSymbol: sel)]]]]]. ^ list asSortedCollection! ! !PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:26'! existsCallIn: aMethodRef "Here existsCompiledCallIn: (see also comment there) is sufficient to query for enabled and failed, but not for disabled prim calls: so check for disabled ones in sources, too." ^ (self existsCompiledCallIn: aMethodRef) or: [self existsDisabledCallIn: aMethodRef]! ! !PCCByCompilation methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:07'! existsDisabledCallIn: aMethodRef | src | ^ (self existsCompiledCallIn: aMethodRef) not and: ["higher priority to avoid source file accessing errors" [src := aMethodRef sourceString] valueAt: self higherPriority. self methodSourceContainsDisabledCall: src]! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'! disabled2EnabledPrimMethodString: aSourceString | start stop primString extract | extract := self extractDisabledPrimStringFrom: aSourceString. primString := extract at: 1. start := extract at: 2. stop := start + primString size - 1. ^ aSourceString copyReplaceFrom: start to: stop with: (self disabled2EnabledPrimString: primString)! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:26'! disabled2EnabledPrimString: aDisabledPrimString "remove comment quotes and comment after first comment quote" | enabledPrimString | enabledPrimString := aDisabledPrimString copyFrom: self comment size + 2 to: aDisabledPrimString size - 1. ^ enabledPrimString! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'! enabled2DisabledPrimMethodString: aSourceString | start stop primString extract | extract := self extractEnabledPrimStringFrom: aSourceString. primString := extract at: 1. start := extract at: 2. stop := start + primString size - 1. ^ aSourceString copyReplaceFrom: start to: stop with: (self enabled2DisabledPrimString: primString)! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'! enabled2DisabledPrimString: anEnabledPrimString | disabledPrimString | disabledPrimString := '"' , self comment , anEnabledPrimString , '"'. ^ disabledPrimString! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:28'! extractCallNamesFromPrimString: aString "method works for both enabled and disabled prim strings" "<primitive: 'doSomething' module:'ModuleFoo'" | tokens | tokens _ aString findTokens: ''''. ^ (tokens at: 2) -> (tokens at: 4 ifAbsent: [nil])! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:10'! extractDisabledPrimStringFrom: aSourceString | startString start stop | startString := self disabledPrimStartString. start := aSourceString findString: startString. start = 0 ifTrue: [^ nil]. stop := aSourceString indexOf: self disabledPrimStopChar startingAt: start + startString size. stop = 0 ifTrue: [^ nil]. ^ {aSourceString copyFrom: start to: stop. start}! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'! extractEnabledPrimStringFrom: aSourceString | startString start stop | startString := self enabledPrimStartString. start := aSourceString findString: startString. start = 0 ifTrue: [^ nil]. stop := aSourceString indexOf: self enabledPrimStopChar startingAt: start + startString size. stop = 0 ifTrue: [^ nil]. ^ {aSourceString copyFrom: start to: stop. start}! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/7/2004 03:29'! higherPriority "this priority seems to be necessary to avoid source file accessing errors" ^ Processor userSchedulingPriority + 1! ! !PCCByCompilation methodsFor: 'private' stamp: 'sr 6/11/2004 07:06'! methodSourceContainsDisabledCall: methodSource ^ (methodSource findString: self disabledPrimStartString) ~= 0! ! !PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:37'! privateDisableCallIn: aMethodRef "Disables enabled or failed external prim call by recompiling method with prim call commented out, will be called by superclass." | src newMethodSource | "higher priority to avoid source file accessing errors" [src := aMethodRef sourceString] valueAt: self higherPriority. newMethodSource := self enabled2DisabledPrimMethodString: src. "higher priority to avoid source file accessing errors" [aMethodRef actualClass compile: newMethodSource classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol) notifying: nil] valueAt: self higherPriority! ! !PCCByCompilation methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:10'! privateEnableCallIn: aMethodRef "Enables disabled external prim call by recompiling method with prim call taken from disabling comment, will be called by superclass." | src newMethodSource | "higher priority to avoid source file accessing errors" [src := aMethodRef sourceString] valueAt: self higherPriority. newMethodSource := self disabled2EnabledPrimMethodString: src. "higher priority to avoid source file accessing errors" [aMethodRef actualClass compile: newMethodSource classified: (aMethodRef actualClass whichCategoryIncludesSelector: aMethodRef methodSymbol) notifying: nil] valueAt: self higherPriority! ! !PCCByCompilation commentStamp: 'sr 6/16/2004 09:00' prior: 0! This class is for switching external prim calls (primitiveExternalCall) on and off. It is best suited for permanently switching plugin calls off while preserving the possibility to switch them on later. For plugin testing purposes you probably should use PCCByLiterals for temporarily switch on/off them instead. It works on a source code basis by compilation: Disabling works by putting an enabled prim call into a special comment followed by a recompile to transform it into a disabled one. Enabling works by pulling the disabled prim call out of the special comment followed by a recompile to transform it into an enabled one. As a consequence, enabling of prims only works with method sources containing the mentioned special comment, which normally has been generated by this tool for disabling the corresponding prim. Please look into superclass PrimCallControllerAbstract for more info and the user interface. Structure: No instVars here: look into superclass. Implementation note: To harden it for sunit testing purposes some special accessing of the source code has been necessary: to avoid accessing different processes a sources file at once, followed by generating garbage, the process priority of actions leading to these accesses has been increased (sunit tests run in the background). A better solution would be to introduce a source file locking mechanism.! ]style[(107 11 138 13 5 11 62 14 3 9 124 8 245 9 36 9 26 28 26 93 20 384)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2FAccuny#12,f3FAccuny#12,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2,FAccuny#15uf2,f2! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:22'! classToBeTested ^ PCCByCompilation! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:36'! disabledCallSelectors ^ #(#cDisabledRealExternalCall #cDisabledRealExternalCallNaked #cDisabledRealExternalCallOrPrimitiveFailed #cDisabledExternalCallWithoutModule )! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'! enabledCallSelectors ^ #(#cRealExternalCall #cRealExternalCallNaked #cRealExternalCallOrPrimitiveFailed #cExternalCallWithoutModule )! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:44'! exampleModuleName ^ 'CPCCT'! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'! failModuleName ^ 'CFailModule'! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:14'! failedCallSelector ^ #cFailedCall! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:40'! methodSelectorsToExampleModule ^ #(#cExternalCall1 #cExternalCall2 )! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! moduleNameNotWithSingularCallName ^ 'CNotOne'! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! moduleNameWithSingularCallName ^ 'COne'! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 09:52'! noExternalCallSelector ^ #cNoExternalCall! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:28'! realExternalCallOrPrimitiveFailedSelector ^ #cRealExternalCallOrPrimitiveFailed! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'! singularCallName "occurrs exactly once as prim call name in >>cSingularExternalCall" ^ 'cSingularExternalCall'! ! !PCCByCompilationTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:33'! singularCallSelector ^ #cSingularExternalCall! ! !PCCByCompilationTest methodsFor: 'example module' stamp: 'sr 6/15/2004 20:49'! cExternalCall1 <primitive: 'prim1' module: 'CPCCT'> ! ! !PCCByCompilationTest methodsFor: 'example module' stamp: 'sr 6/15/2004 20:49'! cExternalCall2 <primitive:'prim2'module:'CPCCT'> self primitiveFailed! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/11/2004 05:36'! cDisabledExternalCallWithoutModule "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName'>" ^ 'Hello World!!'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! cDisabledRealExternalCall "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>" ^ 'Hello World!!'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! cDisabledRealExternalCallNaked "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>"! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 23:54'! cDisabledRealExternalCallOrPrimitiveFailed "{prim disabled by PCCByCompilation} <primitive: 'primGetModuleName' module:'LargeIntegers'>" self primitiveFailed! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'! cExternalCallWithoutModule <primitive: 'primGetModuleName'> ^ 'Hello World!!'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 20:48'! cFailedCall <primitive: 'primGetModuleName' module:'CFailModule'> ^ 'failed call'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:48'! cNoExternalCall ^ 'Hello World!!'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! cRealExternalCall <primitive: 'primGetModuleName' module:'LargeIntegers'> ^ 'Hello World!!'! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! cRealExternalCallNaked <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 20:49'! cRealExternalCallOrPrimitiveFailed <primitive: 'primGetModuleName' module:'LargeIntegers'> self primitiveFailed! ! !PCCByCompilationTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 04:35'! cSingularExternalCall <primitive: 'cSingularExternalCall' module:'COne'> ^ 'Hello World!!'! ! !PCCByCompilationTest commentStamp: 'sr 6/14/2004 22:05' prior: 0! PCCByCompilation tests. Tests are in the superclass and inherited from there.! !PCCByCompilationTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 12:01'! isAbstract ^ false! ! !PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:04'! extractCallModuleNames: aMethodRef ^ (self existsCallIn: aMethodRef) ifTrue: [self extractCallModuleNamesFromLiterals: aMethodRef]! ! !PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/11/2004 07:05'! methodsWithCall ^ self methodsWithCompiledCall! ! !PCCByLiterals methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:24'! methodsWithDisabledCall ^ self methodsWithCompiledCall select: [:mRef | (mRef compiledMethod literals first at: 4) = -2]! ! !PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:04'! existsCallIn: aMethodRef "Here >>existsCompiledCallIn: (see also comment there) is sufficient to query for all enabled, failed and disabled prim calls; for the by compiler version it is not sufficient for disabled ones." ^ self existsCompiledCallIn: aMethodRef! ! !PCCByLiterals methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:30'! existsDisabledCallIn: aMethodRef ^ (self existsCompiledCallIn: aMethodRef) and: [(aMethodRef compiledMethod literals first at: 4) = -2]! ! !PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:35'! privateDisableCallIn: aMethodRef "Disables enabled or failed external prim call by filling function ref literal with special fail value, will be called by superclass." aMethodRef compiledMethod literals first at: 4 put: -2! ! !PCCByLiterals methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:07'! privateEnableCallIn: aMethodRef "Enables disabled external prim call." self privateEnableViaLiteralIn: aMethodRef! ! !PCCByLiterals commentStamp: 'sr 6/16/2004 09:14' prior: 0! This class is for switching external prim calls (primitiveExternalCall) on and off. It is best suited for plugin testing purposes with temporarily switching plugin calls off and on. For permanently switching plugin calls off while preserving the possibility to switch them on later, you should use PCCByCompilation instead. It works by manipulating literals in the CompiledMethods: Disabling works by changing the function index in the first literal of the CompiledMethod to a negative value (-2). This leads to a fast fail (value -2 is used for disabling to make a difference to the standard failed value of -1). Enabling works by changing the function index in the first literal of the CompiledMethod to 0, followed by flushing the method cache. This enforces a fresh lookup. Please look into superclass PrimCallControllerAbstract for more info and the user interface. Structure: No instVars here: look into superclass.! ]style[(136 11 40 11 101 16 10 1 9 2 14 8 26 9 224 8 157 28 26 91)f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2,f2LPrimCallControllerAbstract Comment;,f2! !PCCByLiteralsTest methodsFor: 'tests' stamp: 'sr 6/7/2004 11:30'! setUp super setUp. "disable external calls" (self class selectors select: [:sel | sel beginsWith: 'lDisabled']) do: [:sel | (self class >> sel) literals first at: 4 put: -2]! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/11/2004 05:23'! classToBeTested ^ PCCByLiterals! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:37'! disabledCallSelectors ^ #(#lDisabledRealExternalCall #lDisabledRealExternalCallNaked #lDisabledRealExternalCallOrPrimitiveFailed #lDisabledExternalCallWithoutModule )! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:34'! enabledCallSelectors ^ #(#lRealExternalCall #lRealExternalCallNaked #lRealExternalCallOrPrimitiveFailed #lExternalCallWithoutModule )! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:45'! exampleModuleName ^ 'LPCCT'! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/15/2004 02:42'! failModuleName ^ 'LFailModule'! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:12'! failedCallSelector ^ #lFailedCall! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:41'! methodSelectorsToExampleModule ^ #(#lExternalCall1 #lExternalCall2 )! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! moduleNameNotWithSingularCallName ^ 'LNotOne'! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! moduleNameWithSingularCallName ^ 'LOne'! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:16'! noExternalCallSelector ^ #lNoExternalCall! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:29'! realExternalCallOrPrimitiveFailedSelector ^ #lRealExternalCallOrPrimitiveFailed! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/7/2004 10:54'! singularCallName "occurrs exactly once as prim call name in >>lSingularExternalCall" ^ 'lSingularExternalCall'! ! !PCCByLiteralsTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:32'! singularCallSelector ^ #lSingularExternalCall! ! !PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'! lExternalCall1 <primitive: 'prim1' module: 'LPCCT'> ! ! !PCCByLiteralsTest methodsFor: 'example module' stamp: 'sr 6/7/2004 08:39'! lExternalCall2 <primitive:'prim2'module:'LPCCT'> self primitiveFailed! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 08:51'! lDisabledExternalCallWithoutModule <primitive: 'primGetModuleName'> ^ 'Hello World!!'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lDisabledRealExternalCall <primitive: 'primGetModuleName' module:'LargeIntegers'> ^ 'Hello World!!'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lDisabledRealExternalCallNaked <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lDisabledRealExternalCallOrPrimitiveFailed <primitive: 'primGetModuleName' module:'LargeIntegers'> "primitiveExternalCall" self primitiveFailed! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:59'! lExternalCallWithoutModule <primitive: 'primGetModuleName'> "primitiveExternalCall" ^ 'Hello World!!'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/15/2004 02:41'! lFailedCall <primitive: 'primGetModuleName' module:'LFailModule'> ^ 'failed call'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 09:57'! lNoExternalCall ^ 'Hello World!!'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lRealExternalCall <primitive: 'primGetModuleName' module:'LargeIntegers'> ^ 'Hello World!!'! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lRealExternalCallNaked <primitive: 'primGetModuleName' module:'LargeIntegers'>! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/13/2004 21:14'! lRealExternalCallOrPrimitiveFailed <primitive: 'primGetModuleName' module:'LargeIntegers'> self primitiveFailed! ! !PCCByLiteralsTest methodsFor: 'test methods' stamp: 'sr 6/7/2004 10:52'! lSingularExternalCall <primitive: 'lSingularExternalCall' module:'LOne'> ^ 'Hello World!!'! ! !PCCByLiteralsTest commentStamp: 'sr 6/14/2004 22:05' prior: 0! PCCByLiterals tests. Tests are in the superclass and inherited from there.! !PCCByLiteralsTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 12:01'! isAbstract ^ false! ! !PCXReadWriter methodsFor: 'private-decoding' stamp: 'md 11/14/2003 16:51'! readHeader | xMin xMax yMin yMax | self next. "skip over manufacturer field" version _ self next. encoding _ self next. bitsPerPixel _ self next. xMin _ self nextWord. yMin _ self nextWord. xMax _ self nextWord. yMax _ self nextWord. width _ xMax - xMin + 1. height _ yMax - yMin + 1. self next: 4. "skip over device resolution" self next: 49. "skip over EGA color palette" colorPlanes _ self next. rowByteSize _ self nextWord. isGrayScale _ (self next: 2) = 2. self next: 58. "skip over filler" ! ! !PCXReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('pcx')! ! !PDA methodsFor: 'currentItem' stamp: 'sw 5/23/2001 13:52'! acceptCurrentItemText: aText "Accept into the current item from the text provided, and update lists accordingly" currentItem ifNil: [self inform: 'Can''t accept -- no item is selected'. ^ false]. viewDescriptionOnly ifTrue: [currentItem description: aText string. ^ true]. currentItem readFrom: aText. (currentItem isKindOf: PDAEvent) ifTrue: [self updateScheduleList]. (currentItem isMemberOf: PDAToDoItem) ifTrue: [self updateToDoList]. (currentItem isMemberOf: PDAPerson) ifTrue: [self updatePeopleList]. (currentItem isMemberOf: PDARecord) ifTrue: [self updateNotesList]. ^ true! ! !PDA methodsFor: 'date' stamp: 'aoy 2/15/2003 21:33'! setDate: aDate fromButton: aButton down: down dateButtonPressed ifNotNil: [dateButtonPressed setSwitchState: false]. dateButtonPressed := down ifTrue: [self selectDate: aDate. aButton] ifFalse: [self selectDate: nil. nil]. self currentItem: nil. aButton ifNotNil: [aButton owner owner highlightToday "ugly hack to restore highlight for today"]! ! !PDA methodsFor: 'example' stamp: 'sw 8/28/2002 23:12'! sampleNotes ^ { PDARecord new key: 'home'; description: 'sprinkler schedule'. PDARecord new key: 'home'; description: 'directions to our house Take the expressway, #93 south Then south on Rte 24 East at the T with 195 Take exit 12 and go right to Faunce Corner Cross rte 6, continue on Old Westport Rd takes a bend left and becomes Chase Rd Continue for 3.5-4 mi Rt at T intersection on Russell Mills Rd Pass DPW on left Lg Yellow bldg Davall''s store left on Rocko Dundee Rd down a swail and up. We''re #419 on the left'. PDARecord new key: 'work'; description: 'archaeology memo'. PDARecord new key: 'work'; description: 'worlds and envts memo'. PDARecord new key: 'work'; description: PDA comment asString. }! ! !PDA methodsFor: 'example' stamp: 'brp 9/3/2003 08:45'! sampleScheduleList ^ { PDAEvent new key: 'home'; date: Date today; description: 'wake up'; time: (Time hour: 6 minute: 0 second: 0). PDAEvent new key: 'home'; date: Date today; description: 'go for a run'; time: (Time hour: 7 minute: 0 second: 0). PDAEvent new key: 'home'; date: Date today; description: 'take a shower'; time: (Time hour: 8 minute: 0 second: 0). PDAEvent new key: 'home'; date: (Date today addDays: 2); description: 'dinner out'; time: (Time hour: 18 minute: 0 second: 0). PDAEvent new key: 'work'; date: (Date today addDays: 1); description: 'conf call'; time: (Time hour: 10 minute: 0 second: 0). PDAEvent new key: 'work'; date: (Date today addDays: 2); description: 'Leave for Conference'; time: (Time hour: 8 minute: 0 second: 0). PDAEvent new key: 'work'; date: Date today; description: 'call Boss'; time: (Time hour: 15 minute: 0 second: 0). PDAEvent new key: 'work'; date: Date today; description: 'Call about 401k'; time: (Time hour: 10 minute: 0 second: 0). }! ! !PDA methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:27'! loadDatabase | aName aFileStream list | aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'. aName ifNil: [^ self]. "User made no choice" aName == #none ifTrue: [^ self inform: 'Sorry, no suitable files found (names should end with .data or .data.gz)']. aFileStream _ FileStream oldFileNamed: aName. list _ aFileStream fileInObjectAndCode. userCategories _ list first. allPeople _ list second. allEvents _ list third. recurringEvents _ list fourth. allToDoItems _ list fifth. allNotes _ list sixth. date _ Date today. self selectCategory: 'all'! ! !PDA methodsFor: 'initialization' stamp: 'dgd 2/22/2003 13:28'! mergeDatabase | aName aFileStream list | aName _ Utilities chooseFileWithSuffixFromList: #('.pda' '.pda.gz' ) withCaption: 'Choose a file to load'. aName ifNil: [^ self]. "User made no choice" aName == #none ifTrue: [^ self inform: 'Sorry, no suitable files found (names should end with .data or .data.gz)']. aFileStream _ FileStream oldFileNamed: aName. list _ aFileStream fileInObjectAndCode. userCategories _ (list first , userCategories) asSet asArray sort. allPeople _ (list second , allPeople) asSet asArray sort. allEvents _ (list third , allEvents) asSet asArray sort. recurringEvents _ (list fourth , recurringEvents) asSet asArray sort. allToDoItems _ (list fifth , allToDoItems) asSet asArray sort. allNotes _ ((list sixth) , allNotes) asSet asArray sort. date _ Date today. self selectCategory: 'all'! ! !PDA methodsFor: 'initialization' stamp: 'ar 8/19/2001 16:35'! openAsMorphIn: window "PDA new openAsMorph openInWorld" "Create a pluggable version of all the morphs for a Browser in Morphic" | dragNDropFlag paneColor chooser | window color: Color black. paneColor _ (Color r: 0.6 g: 1.0 b: 0.0). window model: self. Preferences alternativeWindowLook ifTrue:[ window color: Color white. window paneColor: paneColor]. dragNDropFlag _ Preferences browseWithDragNDrop. window addMorph: ((PluggableListMorph on: self list: #peopleListItems selected: #peopleListIndex changeSelected: #peopleListIndex: menu: #peopleMenu: keystroke: #peopleListKey:from:) enableDragNDrop: dragNDropFlag) frame: (0@0 corner: 0.3@0.25). window addMorph: ((chooser _ PDAChoiceMorph new color: paneColor) contentsClipped: 'all'; target: self; actionSelector: #chooseFrom:categoryItem:; arguments: {chooser}; getItemsSelector: #categoryChoices) frame: (0@0.25 corner: 0.3@0.3). window addMorph: ((MonthMorph newWithModel: self) color: paneColor; extent: 148@109) frame: (0.3@0 corner: 0.7@0.3). window addMorph: (PDAClockMorph new color: paneColor; faceColor: (Color r: 0.4 g: 0.8 b: 0.6)) "To match monthMorph" frame: (0.7@0 corner: 1.0@0.3). window addMorph: ((PluggableListMorph on: self list: #toDoListItems selected: #toDoListIndex changeSelected: #toDoListIndex: menu: #toDoMenu: keystroke: #toDoListKey:from:) enableDragNDrop: dragNDropFlag) frame: (0@0.3 corner: 0.3@0.7). window addMorph: ((PluggableListMorph on: self list: #scheduleListItems selected: #scheduleListIndex changeSelected: #scheduleListIndex: menu: #scheduleMenu: keystroke: #scheduleListKey:from:) enableDragNDrop: dragNDropFlag) frame: (0.3@0.3 corner: 0.7@0.7). window addMorph: ((PluggableListMorph on: self list: #notesListItems selected: #notesListIndex changeSelected: #notesListIndex: menu: #notesMenu: keystroke: #notesListKey:from:) enableDragNDrop: dragNDropFlag) frame: (0.7@0.3 corner: 1@0.7). window addMorph: (PluggableTextMorph on: self text: #currentItemText accept: #acceptCurrentItemText: readSelection: #currentItemSelection menu: #currentItemMenu:) frame: (0@0.7 corner: 1@1). Preferences alternativeWindowLook ifFalse:[ window firstSubmorph color: paneColor. ]. window updatePaneColors. window step. ^ window! ! !PDA methodsFor: 'notes' stamp: 'HEG 5/18/2004 05:38'! notesMenu: aMenu aMenu add: 'add new note' target: self selector: #addNote. notesListIndex > 0 ifTrue: [aMenu add: 'remove note' target: self selector: #removeNote]. ^ aMenu! ! !PDA methodsFor: 'schedule' stamp: 'gm 3/2/2003 18:26'! updateScheduleList (date isNil and: [category ~= 'recurring']) ifTrue: [scheduleList _ Array new. scheduleListIndex _ 0. ^ self changed: #scheduleListItems]. scheduleList _ (category = 'recurring' ifTrue: ["When 'recurring' is selected, edit actual masters" (recurringEvents select: [:c | c matchesKey: category andMatchesDate: date]) ] ifFalse: ["Otherwise, recurring events just spawn copies." ((allEvents select: [:c | c matchesKey: category andMatchesDate: date]) , ((recurringEvents select: [:c | c matchesKey: category andMatchesDate: date]) collect: [:re | (re as: PDAEvent) date: date])) ])sort. scheduleListIndex _ scheduleList indexOf: currentItem. self changed: #scheduleListItems! ]style[(18 3 4 16 8 4 11 14 12 3 5 9 17 3 1 7 4 10 18 4 12 4 8 3 11 14 51 7 15 16 3 2 1 13 8 17 4 19 48 8 9 16 3 2 1 13 8 17 4 13 15 18 3 2 1 13 8 17 4 21 4 3 2 5 8 18 4 13 17 3 12 10 11 3 4 10 18)f1b,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c197197121,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c197197121,f1,f1cmagenta;,f1,f1c197197121,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c197197121,f1,f1c147045000,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c147045000,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cred;,f1,f1cblue;i,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1cmagenta;,f1,f1c197197121! ! !PDA methodsFor: 'to do' stamp: 'dgd 2/22/2003 13:26'! declareItemDone | report | report := FillInTheBlank request: 'This item will be declared done as of ' , date printString , '. Please give a short summary of status' initialAnswer: 'Completed.'. (report isNil or: [report isEmpty]) ifTrue: [^self]. currentItem dayDone: date; result: report. self currentItem: currentItem! ! !PDAChoiceMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'! drawOn: aCanvas | offset | offset _ 4@(bounds height - self fontToUse height // 2). aCanvas frameAndFillRectangle: bounds fillColor: backgroundColor borderWidth: 1 borderColor: Color black. aCanvas drawString: contents in: ((bounds translateBy: offset) intersect: bounds) font: self fontToUse color: Color black. ! ! !PDAChoiceMorph commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDAClockMorph commentStamp: '<historical>' prior: 0! See PDA comment. '! !PDAEvent methodsFor: 'comparing' stamp: 'dgd 2/22/2003 14:39'! <= other date = other date ifFalse: [^date < other date]. time isNil ifTrue: [^true]. other time isNil ifTrue: [^false]. ^time <= other time! ! !PDAEvent commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDAMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGray! ! !PDAMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:48'! initialize "initialize the state of the receiver" super initialize. "" self extent: 406 @ 408. PDA new initialize openAsMorphIn: self! ! !PDAMorph methodsFor: 'parts bin' stamp: 'sw 7/12/2001 22:50'! initializeToStandAlone super initializeToStandAlone. self fullBounds "seemingly necessary to get its icon right in a parts bin"! ! !PDAMorph methodsFor: 'stepping' stamp: 'di 4/9/2001 16:54'! wantsStepsWhenCollapsed "Keep time up to date in title bar" ^ true! ! !PDAMorph methodsFor: 'stepping and presenter' stamp: 'di 4/3/2001 22:09'! step self setLabel: model labelString. "Super won't step if collapsed" super step. ! ! !PDAMorph commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDAMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:51'! descriptionForPartsBin ^ self partName: 'PDA' categories: #('Useful') documentation: 'A Personal Digital Assistant'! ! !PDAPerson commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDARecord commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDARecurringEvent methodsFor: 'date' stamp: 'dgd 2/22/2003 14:51'! matchesDate: aDate (firstDate isNil or: [firstDate > aDate]) ifTrue: [^false]. (lastDate notNil and: [lastDate < aDate]) ifTrue: [^false]. recurrence == #eachDay ifTrue: [^true]. recurrence == #dayOfWeek ifTrue: [^aDate weekday = firstDate weekday]. recurrence == #dayOfMonth ifTrue: [^aDate dayOfMonth = firstDate dayOfMonth]. recurrence == #dateOfYear ifTrue: [^aDate monthIndex = firstDate monthIndex and: [aDate dayOfMonth = firstDate dayOfMonth]]. recurrence == #nthWeekdayOfMonth ifTrue: [^aDate weekday = firstDate weekday and: [(aDate dayOfMonth - 1) // 7 = ((firstDate dayOfMonth - 1) // 7)]]. recurrence == #nthWeekdayOfMonthEachYear ifTrue: [^aDate monthIndex = firstDate monthIndex and: [aDate weekday = firstDate weekday and: [(aDate dayOfMonth - 1) // 7 = ((firstDate dayOfMonth - 1) // 7)]]]! ! !PDARecurringEvent commentStamp: '<historical>' prior: 0! See PDA comment. ! !PDAToDoItem commentStamp: '<historical>' prior: 0! See PDA comment. ! !PNGReadWriter methodsFor: 'accessing' stamp: 'nk 7/30/2004 17:51'! nextImage bigEndian := SmalltalkImage current isBigEndian. filtersSeen := Bag new. globalDataChunk := nil. transparentPixelValue := nil. unknownChunks := Set new. stream reset. stream binary. stream skip: 8. [stream atEnd] whileFalse: [self processNextChunk]. "Set up our form" palette ifNotNil: ["Dump the palette if it's the same as our standard palette" palette = (StandardColors copyFrom: 1 to: palette size) ifTrue: [palette := nil]]. (depth <= 8 and: [palette notNil]) ifTrue: [form := ColorForm extent: width @ height depth: depth. form colors: palette] ifFalse: [form := Form extent: width @ height depth: depth]. backColor ifNotNil: [form fillColor: backColor]. chunk := globalDataChunk ifNil: [self error: 'image data is missing']. chunk ifNotNil: [self processIDATChunk]. unknownChunks isEmpty ifFalse: ["Transcript show: ' ',unknownChunks asSortedCollection asArray printString." ]. self debugging ifTrue: [Transcript cr; show: 'form = ' , form printString. Transcript cr; show: 'colorType = ' , colorType printString. Transcript cr; show: 'interlaceMethod = ' , interlaceMethod printString. Transcript cr; show: 'filters = ' , filtersSeen sortedCounts asArray printString]. ^form! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55'! processBackgroundChunk | val red green blue max | "Transcript show: ' BACKGROUND: ',chunk printString." colorType = 3 ifTrue: [ backColor := palette at: chunk first + 1. ^self ]. max _ (2 raisedTo: bitsPerChannel) - 1. (colorType = 0 or: [colorType = 4]) ifTrue: [ val _ chunk unsignedShortAt: 1 bigEndian: true. backColor := Color gray: val / max. ^self ]. (colorType = 2 or: [colorType = 6]) ifTrue: [ red _ chunk unsignedShortAt: 1 bigEndian: true. green _ chunk unsignedShortAt: 3 bigEndian: true. blue _ chunk unsignedShortAt: 5 bigEndian: true. backColor := Color r: red/max g: green/max b: blue/max. ^self ]. "self halt." "==== The bKGD chunk specifies a default background color to present the image against. Note that viewers are not bound to honor this chunk; a viewer can choose to use a different background. For color type 3 (indexed color), the bKGD chunk contains: Palette index: 1 byte The value is the palette index of the color to be used as background. For color types 0 and 4 (grayscale, with or without alpha), bKGD contains: Gray: 2 bytes, range 0 .. (2^bitdepth)-1 (For consistency, 2 bytes are used regardless of the image bit depth.) The value is the gray level to be used as background. For color types 2 and 6 (truecolor, with or without alpha), bKGD contains: Red: 2 bytes, range 0 .. (2^bitdepth)-1 Green: 2 bytes, range 0 .. (2^bitdepth)-1 Blue: 2 bytes, range 0 .. (2^bitdepth)-1 (For consistency, 2 bytes per sample are used regardless of the image bit depth.) This is the RGB color to be used as background. When present, the bKGD chunk must precede the first IDAT chunk, and must follow the PLTE chunk, if any. ===" ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/10/2004 23:55'! processIHDRChunk width _ chunk longAt: 1 bigEndian: true. height _ chunk longAt: 5 bigEndian: true. bitsPerChannel _ chunk at: 9. colorType _ chunk at: 10. "compression _ chunk at: 11." "TODO - validate compression" "filterMethod _ chunk at: 12." "TODO - validate filterMethod" interlaceMethod _ chunk at: 13. "TODO - validate interlace method" (#(2 4 6) includes: colorType) ifTrue: [depth _ 32]. (#(0 3) includes: colorType) ifTrue: [ depth _ bitsPerChannel min: 8. colorType = 0 ifTrue: [ "grayscale" palette := self grayColorsFor: depth. ]. ]. bitsPerPixel _ (BPP at: colorType+1) at: bitsPerChannel highBit. bytesPerScanline _ width * bitsPerPixel + 7 // 8. rowSize _ width * depth + 31 >> 5. ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19'! processInterlaced | z filter bytesPerPass startingCol colIncrement rowIncrement startingRow cx sc temp | startingCol _ #(0 4 0 2 0 1 0 ). colIncrement _ #(8 8 4 4 2 2 1 ). rowIncrement _ #(8 8 8 4 4 2 2 ). startingRow _ #(0 0 4 0 2 0 1 ). z _ ZLibReadStream on: chunk from: 1 to: chunk size. 1 to: 7 do: [:pass | (self doPass: pass) ifTrue: [cx _ colIncrement at: pass. sc _ startingCol at: pass. bytesPerPass _ width - sc + cx - 1 // cx * bitsPerPixel + 7 // 8. prevScanline _ ByteArray new: bytesPerPass. thisScanline _ ByteArray new: bytesPerScanline. (startingRow at: pass) to: height - 1 by: (rowIncrement at: pass) do: [:y | filter _ z next. filtersSeen add: filter. (filter isNil or: [(filter between: 0 and: 4) not]) ifTrue: [^ self]. thisScanline _ z next: bytesPerPass into: thisScanline startingAt: 1. self filterScanline: filter count: bytesPerPass. self copyPixels: y at: sc by: cx. temp := prevScanline. prevScanline := thisScanline. thisScanline := temp. ] ] ]. z atEnd ifFalse:[self error:'Unexpected data'].! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/11/2004 12:14'! processNextChunk | length chunkType crc chunkCrc | length _ self nextLong. chunkType _ (self next: 4) asString. chunk _ self next: length. chunkCrc := self nextLong bitXor: 16rFFFFFFFF. crc := self updateCrc: 16rFFFFFFFF from: 1 to: 4 in: chunkType. crc := self updateCrc: crc from: 1 to: length in: chunk. crc = chunkCrc ifFalse:[ self error: 'PNGReadWriter crc error in chunk ', chunkType. ]. chunkType = 'IEND' ifTrue: [^self "*should* be the last chunk"]. chunkType = 'sBIT' ifTrue: [^self processSBITChunk "could indicate unusual sample depth in original"]. chunkType = 'gAMA' ifTrue: [^self "indicates gamma correction value"]. chunkType = 'bKGD' ifTrue: [^self processBackgroundChunk]. chunkType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk]. chunkType = 'tRNS' ifTrue: [^self processTransparencyChunk]. chunkType = 'IHDR' ifTrue: [^self processIHDRChunk]. chunkType = 'PLTE' ifTrue: [^self processPLTEChunk]. chunkType = 'IDAT' ifTrue: [ "---since the compressed data can span multiple chunks, stitch them all together first. later, if memory is an issue, we need to figure out how to do this on the fly---" globalDataChunk _ globalDataChunk ifNil: [chunk] ifNotNil: [globalDataChunk,chunk]. ^self ]. unknownChunks add: chunkType. ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/29/2004 04:19'! processNonInterlaced | z filter temp copyMethod debug | debug := self debugging. copyMethod _ #(copyPixelsGray: nil copyPixelsRGB: copyPixelsIndexed: copyPixelsGrayAlpha: nil copyPixelsRGBA:) at: colorType+1. debug ifTrue: [ Transcript cr; nextPutAll: 'NI chunk size='; print: chunk size ]. z _ ZLibReadStream on: chunk from: 1 to: chunk size. prevScanline _ ByteArray new: bytesPerScanline. thisScanline := ByteArray new: bytesPerScanline. 0 to: height-1 do: [ :y | filter _ (z next: 1) first. debug ifTrue:[filtersSeen add: filter]. thisScanline _ z next: bytesPerScanline into: thisScanline startingAt: 1. (debug and: [ thisScanline size < bytesPerScanline ]) ifTrue: [ Transcript nextPutAll: ('wanted {1} but only got {2}' format: { bytesPerScanline. thisScanline size }); cr ]. filter = 0 ifFalse:[self filterScanline: filter count: bytesPerScanline]. self perform: copyMethod with: y. temp := prevScanline. prevScanline := thisScanline. thisScanline := temp. ]. z atEnd ifFalse:[self error:'Unexpected data']. debug ifTrue: [Transcript nextPutAll: ' compressed size='; print: z position ]. ! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 2/11/2004 01:02'! processPLTEChunk | colorCount i | colorCount _ chunk size // 3. "TODO - validate colorCount against depth" palette _ Array new: colorCount. 0 to: colorCount-1 do: [ :index | i _ index * 3 + 1. palette at: index+1 put: (Color r: (chunk at: i)/255.0 g: (chunk at: i+1)/255.0 b: (chunk at: i+2)/255.0) ].! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'ar 12/12/2003 18:33'! processSBITChunk | rBits gBits bBits aBits | colorType = 6 ifFalse:[^self]. rBits := chunk at: 1. gBits := chunk at: 2. bBits := chunk at: 3. aBits := chunk at: 4. (rBits = 5 and:[gBits = 5 and:[bBits = 5 and:[aBits = 1]]]) ifTrue:[ depth := 16. ].! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 1/1/1970 21:00'! copyPixelsIndexed: y "Handle non-interlaced indexed color mode (colorType = 3)" | hack hackBlt swizzleHack swizzleBlt scanline hackDepth | scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. scanline replaceFrom: 1 to: thisScanline size with: thisScanline startingAt: 1. hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. hack := Form extent: width@1 depth: hackDepth bits: scanline. hackBlt := BitBlt toForm: form. hackBlt sourceForm: hack. hackBlt combinationRule: Form over. hackBlt destOrigin: 0@y. hackBlt width: width; height: 1. (form depth < 8 and:[bigEndian not]) ifTrue:[ swizzleHack := Form new hackBits: scanline. swizzleBlt := BitBlt toForm: swizzleHack. swizzleBlt sourceForm: swizzleHack. swizzleBlt combinationRule: Form over. swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). swizzleBlt copyBits. ]. hackBlt copyBits.! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'nk 7/27/2004 17:18'! copyPixelsRGB: y at: startX by: incX "Handle interlaced RGB color mode (colorType = 2)" | i pixel tempForm tempBits xx loopsToDo | tempForm _ Form extent: width@1 depth: 32. tempBits _ tempForm bits. pixel := LargePositiveInteger new: 4. pixel at: 4 put: 16rFF. loopsToDo _ width - startX + incX - 1 // incX. bitsPerChannel = 8 ifTrue: [ i _ (startX // incX * 3) + 1. xx _ startX+1. 1 to: loopsToDo do: [ :j | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i+1); at: 1 put: (thisScanline at: i+2). tempBits at: xx put: pixel. i _ i + 3. xx _ xx + incX. ] ] ifFalse: [ i _ (startX // incX * 6) + 1. xx _ startX+1. 1 to: loopsToDo do: [ :j | pixel at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i+2); at: 1 put: (thisScanline at: i+4). tempBits at: xx put: pixel. i _ i + 6. xx _ xx + incX. ]. ]. transparentPixelValue ifNotNil: [ startX to: width-1 by: incX do: [ :x | (tempBits at: x+1) = transparentPixelValue ifTrue: [ tempBits at: x+1 put: 0. ]. ]. ]. tempForm displayOn: form at: 0@y rule: Form paint. ! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/18/2004 23:58'! copyPixelsRGBA: y "Handle non-interlaced RGBA color modes (colorType = 6)" | i pixel tempForm tempBits ff | bitsPerChannel = 8 ifTrue: [ ff := Form extent: width@1 depth: 32 bits: thisScanline. cachedDecoderMap ifNil:[cachedDecoderMap := self rgbaDecoderMapForDepth: depth]. (BitBlt toForm: form) sourceForm: ff; destOrigin: 0@y; combinationRule: Form over; colorMap: cachedDecoderMap; copyBits. ^self. ]. tempForm _ Form extent: width@1 depth: 32. tempBits _ tempForm bits. pixel := LargePositiveInteger new: 4. i := -7. 0 to: width-1 do: [ :x | i := i + 8. pixel at: 4 put: (thisScanline at: i+6); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i+2); at: 1 put: (thisScanline at: i+4). tempBits at: x+1 put: pixel. ]. tempForm displayOn: form at: 0@y rule: Form over. ! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'nk 7/27/2004 17:57'! copyPixelsRGBA: y at: startX by: incX "Handle interlaced RGBA color modes (colorType = 6)" | i pixel tempForm tempBits | tempForm _ Form extent: width@1 depth: 32. tempBits _ tempForm bits. pixel := LargePositiveInteger new: 4. bitsPerChannel = 8 ifTrue: [ i _ (startX // incX << 2) + 1. startX to: width-1 by: incX do: [ :x | pixel at: 4 put: (thisScanline at: i+3); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i+1); at: 1 put: (thisScanline at: i+2). tempBits at: x+1 put: pixel. i _ i + 4. ] ] ifFalse: [ i _ (startX // incX << 3) +1. startX to: width-1 by: incX do: [ :x | pixel at: 4 put: (thisScanline at: i+6); at: 3 put: (thisScanline at: i); at: 2 put: (thisScanline at: i+2); at: 1 put: (thisScanline at: i+4). tempBits at: x+1 put: pixel. i _ i + 8. ]. ]. tempForm displayOn: form at: 0@y rule: Form paintAlpha. ! ! !PNGReadWriter methodsFor: 'pixel copies' stamp: 'ar 2/19/2004 00:10'! rgbaDecoderMapForDepth: decoderDepth bigEndian ifTrue:[ depth = 16 ifTrue:[ "Big endian, 32 -> 16 color mapping." ^ColorMap shifts: #(-17 -14 -11 0) masks: #(16rF8000000 16rF80000 16rF800 16r00) ] ifFalse:[ "Big endian, 32 -> 32 color mapping" ^ColorMap shifts: #(-8 -8 -8 24) masks: #(16rFF000000 16rFF0000 16rFF00 16rFF). ]. ]. depth = 16 ifTrue:[ "Little endian, 32 -> 16 color mapping." ^ColorMap shifts: #(7 -6 -19 0) masks: #(16rF8 16rF800 16rF80000 0) ] ifFalse:[ "Little endian, 32 -> 32 color mapping" ^ColorMap shifts: #(-16 0 16 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ].! ! !PNGReadWriter methodsFor: 'miscellaneous' stamp: 'ar 2/11/2004 01:27'! grayColorsFor: d "return a color table for a gray image" palette _ Array new: 1<<d. d = 1 ifTrue: [ palette at: 1 put: Color black. palette at: 2 put: Color white. ^ palette,{Color transparent} ]. d = 2 ifTrue: [ palette at: 1 put: Color black. palette at: 2 put: (Color gray: 85.0 / 255.0). palette at: 3 put: (Color gray: 170.0 / 255.0). palette at: 4 put: Color white. ^ palette,{Color transparent}. ]. d = 4 ifTrue: [ 0 to: 15 do: [ :g | palette at: g+1 put: (Color gray: (g/15) asFloat) ]. ^ palette,{Color transparent} ]. d = 8 ifTrue: [ 0 to: 255 do: [ :g | palette at: g+1 put: (Color gray: (g/255) asFloat) ]. ^ palette "??transparent??" ]. ! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:37'! nextPutImage: aForm "Write out the given form. We're keeping it simple here, no interlacing, no filters." ^self nextPutImage: aForm interlace: 0 filter: 0. "no filtering"! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 7/30/2004 17:51'! nextPutImage: aForm interlace: aMethod filter: aFilterType "Note: For now we keep it simple - interlace and filtering are simply ignored" | crcStream | bigEndian := SmalltalkImage current isBigEndian. form := aForm. width := aForm width. height := aForm height. aForm depth <= 8 ifTrue: [bitsPerChannel := aForm depth. colorType := 3. bytesPerScanline := (width * aForm depth + 7) // 8] ifFalse: [bitsPerChannel := 8. colorType := 6. bytesPerScanline := width * 4]. self writeFileSignature. crcStream := WriteStream on: (ByteArray new: 1000). crcStream resetToStart. self writeIHDRChunkOn: crcStream. self writeChunk: crcStream. form depth <= 8 ifTrue: [crcStream resetToStart. self writePLTEChunkOn: crcStream. self writeChunk: crcStream. form isColorForm ifTrue: [crcStream resetToStart. self writeTRNSChunkOn: crcStream. self writeChunk: crcStream]]. form depth = 16 ifTrue: [crcStream resetToStart. self writeSBITChunkOn: crcStream. self writeChunk: crcStream]. crcStream resetToStart. self writeIDATChunkOn: crcStream. self writeChunk: crcStream. crcStream resetToStart. self writeIENDChunkOn: crcStream. self writeChunk: crcStream! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:51'! updateCrc: oldCrc from: start to: stop in: aCollection ^ZipWriteStream updateCrc: oldCrc from: start to: stop in: aCollection! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 16:04'! writeChunk: crcStream | bytes length crc debug | debug _ self debugging. bytes := crcStream originalContents. length := crcStream position. crc := self updateCrc: 16rFFFFFFFF from: 1 to: length in: bytes. crc := crc bitXor: 16rFFFFFFFF. debug ifTrue: [ Transcript cr; print: stream position; space; nextPutAll: (bytes copyFrom: 1 to: 4) asString; nextPutAll: ' len='; print: length; nextPutAll: ' crc=0x'; nextPutAll: crc hex ]. stream nextNumber: 4 put: length-4. "exclude chunk name" stream next: length putAll: bytes startingAt: 1. stream nextNumber: 4 put: crc. debug ifTrue: [ Transcript nextPutAll: ' afterPos='; print: stream position ]. crcStream resetToStart.! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 16:40'! writeFileSignature stream nextPutAll: #(16r89 16r50 16r4E 16r47 16r0D 16r0A 16r1A 16r0A) asByteArray! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 2/17/2004 14:57'! writeIDATChunkOn: aStream "Write the IDAT chunk" | z | aStream nextPutAll: 'IDAT' asByteArray. z _ ZLibWriteStream on: aStream. form depth <= 8 ifTrue:[self writeType3DataOn: z] ifFalse:[ self writeType6DataOn: z]. self debugging ifTrue: [ Transcript cr; nextPutAll: 'compressed size='; print: aStream position; nextPutAll: ' uncompressed size='; print: z position ] ! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:08'! writeIENDChunkOn: aStream "Write the IEND chunk" aStream nextPutAll: 'IEND' asByteArray.! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:21'! writeIHDRChunkOn: aStream "Write the IHDR chunk" aStream nextPutAll: 'IHDR' asByteArray. aStream nextInt32Put: width. aStream nextInt32Put: height. aStream nextNumber: 1 put: bitsPerChannel. aStream nextNumber: 1 put: colorType. aStream nextNumber: 1 put: 0. "compression" aStream nextNumber: 1 put: 0. "filter method" aStream nextNumber: 1 put: 0. "interlace method" ! ! !PNGReadWriter methodsFor: 'writing' stamp: 'nk 4/17/2004 19:44'! writePLTEChunkOn: aStream "Write the PLTE chunk" | r g b colors | aStream nextPutAll: 'PLTE' asByteArray. (form isColorForm) ifTrue:[colors := form colors] ifFalse:[colors := Color indexedColors copyFrom: 1 to: (1 bitShift: form depth)]. colors do:[:aColor| r := (aColor red * 255) truncated. g := (aColor green * 255) truncated. b := (aColor blue * 255) truncated. aStream nextPut: r; nextPut: g; nextPut: b. ].! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 18:29'! writeSBITChunkOn: aStream "Write the IDAT chunk" aStream nextPutAll: 'sBIT' asByteArray. form depth = 16 ifFalse:[self error: 'Unimplemented feature']. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 5. aStream nextPut: 1.! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 12/12/2003 17:34'! writeTRNSChunkOn: aStream "Write out tRNS chunk" aStream nextPutAll: 'tRNS' asByteArray. form colors do:[:aColor| aStream nextPut: (aColor alpha * 255) truncated. ].! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 1/1/1970 20:58'! writeType3DataOn: zStream "Write color indexed data." | scanline hack hackBlt swizzleBlt swizzleHack hackDepth | scanline := ByteArray new: bytesPerScanline + 3 // 4 * 4. hackDepth := bigEndian ifTrue:[form depth] ifFalse:[form depth negated]. hack := Form extent: width@1 depth: hackDepth bits: scanline. hackBlt := BitBlt toForm: hack. hackBlt sourceForm: form. hackBlt combinationRule: Form over. hackBlt destOrigin: 0@0. hackBlt width: width; height: 1. (form depth < 8 and:[bigEndian not]) ifTrue:[ swizzleHack := Form new hackBits: scanline. swizzleBlt := BitBlt toForm: swizzleHack. swizzleBlt sourceForm: swizzleHack. swizzleBlt combinationRule: Form over. swizzleBlt colorMap: (StandardSwizzleMaps at: form depth). ]. 0 to: height-1 do:[:i| hackBlt sourceOrigin: 0@i; copyBits. swizzleBlt ifNotNil:[swizzleBlt copyBits]. zStream nextPut: 0. "filterType" zStream next: bytesPerScanline putAll: scanline startingAt: 1. ]. zStream close.! ! !PNGReadWriter methodsFor: 'writing' stamp: 'ar 2/19/2004 00:10'! writeType6DataOn: zStream "Write RGBA data." | scanline hack hackBlt cm miscBlt | scanline := ByteArray new: bytesPerScanline. hack := Form extent: width@1 depth: 32 bits: scanline. form depth = 16 ifTrue:[ "Expand 16 -> 32" miscBlt := BitBlt toForm: hack. miscBlt sourceForm: form. miscBlt combinationRule: Form over. miscBlt destOrigin: 0@0. miscBlt width: width; height: 1. ]. hackBlt := BitBlt toForm: hack. hackBlt sourceForm: (miscBlt ifNil:[form] ifNotNil:[hack]). hackBlt combinationRule: Form over. hackBlt destOrigin: 0@0. hackBlt width: width; height: 1. bigEndian ifTrue:[ cm := ColorMap shifts: #(8 8 8 -24) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ] ifFalse:[ cm := ColorMap shifts: #(-16 0 16 0) masks: #(16rFF0000 16rFF00 16rFF 16rFF000000). ]. hackBlt colorMap: cm. 0 to: height-1 do:[:i| miscBlt ifNil:[ hackBlt sourceOrigin: 0@i; copyBits. ] ifNotNil:[ miscBlt sourceOrigin: 0@i; copyBits. hack fixAlpha. hackBlt copyBits. ]. zStream nextPut: 0. "filterType" zStream nextPutAll: scanline. ]. zStream close.! ! !PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:54'! computeSwizzleMapForDepth: depth "Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)." | map swizzled | map := Bitmap new: 256. depth = 4 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 2 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 1 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7). swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5). swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3). swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1). swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. self error: 'Unrecognized depth'! ! !PNGReadWriter class methodsFor: 'as yet unclassified' stamp: 'ar 2/11/2004 00:55'! initialize " PNGReadWriter initialize " BPP _ { #(1 2 4 8 16). #(0 0 0 0 0). #(0 0 0 24 48). #(1 2 4 8 0). #(0 0 0 16 32). #(0 0 0 0 0). #(0 0 0 32 64). #(0 0 0 0 0) }. BlockHeight _ #(8 8 4 4 2 2 1). BlockWidth _ #(8 4 4 2 2 1 1). StandardColors := Color indexedColors collect:[:aColor| Color r: (aColor red * 255) truncated / 255 g: (aColor green * 255) truncated / 255 b: (aColor blue * 255) truncated / 255. ]. StandardSwizzleMaps := Array new: 4. #(1 2 4) do:[:i| StandardSwizzleMaps at: i put: (self computeSwizzleMapForDepth: i)].! ! !PNGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('png')! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test16Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test16BitDisplay self encodeAndDecodeDisplay: 16! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'! test16BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test1Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:43'! test1BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test1BitDisplay self encodeAndDecodeDisplay: 1! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'! test1BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test2Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:43'! test2BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test2BitDisplay self encodeAndDecodeDisplay: 2! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'! test2BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test32Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test32BitDisplay self encodeAndDecodeDisplay: 32! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'! test32BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test4Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:44'! test4BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test4BitDisplay self encodeAndDecodeDisplay: 4! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:56'! test4BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:50'! test8Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:44'! test8BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 00:39'! test8BitDisplay self encodeAndDecodeDisplay: 8! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/11/2004 01:57'! test8BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/12/2004 22:49'! testAlphaCoding self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests' stamp: 'ar 2/29/2004 03:55'! testPngSuite "Requires the suite from ftp://swrinde.nde.swri.edu/pub/png/images/suite/PngSuite.zip to be present as PngSuite.zip" | file zip entries | [file := FileStream readOnlyFileNamed: 'PngSuite.zip'] on: Error do:[:ex| ex return]. file ifNil:[^self]. [zip := ZipArchive new readFrom: file. entries := zip members select:[:mbr| mbr fileName asLowercase endsWith: '.png']. entries do:[:mbr| (mbr fileName asLowercase first = $x) ifTrue: [self encodeAndDecodeWithError: mbr contentStream ] ifFalse: [self encodeAndDecodeStream: mbr contentStream ] ]. ] ensure:[file close].! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlack16 self encodeAndDecodeColor: Color blue depth: 16! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlack32 self encodeAndDecodeColor: Color blue depth: 32! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlack8 self encodeAndDecodeColor: Color blue depth: 8! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlue16 self encodeAndDecodeColor: Color blue depth: 16! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlue32 self encodeAndDecodeColor: Color blue depth: 32! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testBlue8 self encodeAndDecodeColor: Color blue depth: 8! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testGreen16 self encodeAndDecodeColor: Color green depth: 16! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:50'! testGreen32 self encodeAndDecodeColor: Color green depth: 32! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'! testGreen8 self encodeAndDecodeColor: Color green depth: 8! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'! testRed16 self encodeAndDecodeColor: Color red depth: 16! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:48'! testRed32 self encodeAndDecodeColor: Color red depth: 32! ! !PNGReadWriterTest methodsFor: 'colors' stamp: 'ar 2/18/2004 23:49'! testRed8 self encodeAndDecodeColor: Color red depth: 8! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:25'! coloredFiles16 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 16. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{Color red-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADZJ REFUeF7lziEBAAAMAjD6J8b9MRAT80uT65Af8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfmgQdc z9xqBS2pdAAAAABJRU5ErkJggg=='. Color green-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjD6J77jMRAT80sunfIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA68HyT 3Gqf2I6NAAAAAElFTkSuQmCC'. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjD6J77jMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48JxX 3GpYhihrAAAAAElFTkSuQmCC'. Color black-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABHNCSVQFBQUBSsjp7wAAADVJ REFUeF7lziEBAAAMAjDk+xfmMRAT80ty3fIDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA48LbT HD3MKH3GAAAAAElFTkSuQmCC' }! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:24'! coloredFiles32 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 32. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{ Color red -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOIQEAAAwEoe9f +hZjAoFnbfVo+QE/4Af8gB/wA37AD/gBP+AH/IAf8AN+4DlwVA34ajP6EEoAAAAASUVORK5C YII='. Color green -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAAM0lEQVR4XuXOMQ0AAAACIPuX 1hgejAIkPfMDfsAP+AE/4Af8gB/wA37AD/gBP+AH/MA7MFfR+Grvv2BdAAAAAElFTkSuQmCC'. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANElEQVR4XuXOIQEAAAACIP+f 1hkGAp0k7Zcf8AN+wA/4AT/gB/yAH/ADfsAP+AE/4AfOgQFblfhqnnPWHAAAAABJRU5ErkJg gg=='. Color black -> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAANUlEQVR4XuXOMQEAAAwCINc/ tIvhwcFPkuuWH/ADfsAP+AE/4Af8gB/wA37AD/gBP+AHxoEH95UAPU59TTMAAAAASUVORK5C YII=' }! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:19'! coloredFiles8 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 8. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (Base64MimeConverter mimeEncode: (bytes contents readStream)) contents ]. " ^{Color red-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGklEQVR4XmO4cwc/YLgz8hWMfAUjX8EIVQAAbnlwLukXXkcAAAAASUVORK5CYII='. Color green-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmPQ1cUPGHRHvoKRr2DkKxihCgBZ3bQBCq5u/AAAAABJRU5ErkJggg=='. Color blue-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmNwc8MPGNxGvoKRr2DkKxihCgCl7xgQRbPxcwAAAABJRU5ErkJggg=='. Color black-> 'iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAADAFBMVEX///8AAAD///9/f3// AAAA/wAAAP8A/////wD/AP8fHx8/Pz9fX1+fn5+/v7/f398HBwcPDw8XFxcnJycvLy83NzdH R0dPT09XV1dnZ2dvb293d3eHh4ePj4+Xl5enp6evr6+3t7fHx8fPz8/X19fn5+fv7+/39/cA AAAAMgAAZQAAmAAAywAA/wAAADIAMjIAZTIAmDIAyzIA/zIAAGUAMmUAZWUAmGUAy2UA/2UA AJgAMpgAZZgAmJgAy5gA/5gAAMsAMssAZcsAmMsAy8sA/8sAAP8AMv8AZf8AmP8Ay/8A//8y AAAyMgAyZQAymAAyywAy/wAyADIyMjIyZTIymDIyyzIy/zIyAGUyMmUyZWUymGUyy2Uy/2Uy AJgyMpgyZZgymJgyy5gy/5gyAMsyMssyZcsymMsyy8sy/8syAP8yMv8yZf8ymP8yy/8y//9l AABlMgBlZQBlmABlywBl/wBlADJlMjJlZTJlmDJlyzJl/zJlAGVlMmVlZWVlmGVly2Vl/2Vl AJhlMphlZZhlmJhly5hl/5hlAMtlMstlZctlmMtly8tl/8tlAP9lMv9lZf9lmP9ly/9l//+Y AACYMgCYZQCYmACYywCY/wCYADKYMjKYZTKYmDKYyzKY/zKYAGWYMmWYZWWYmGWYy2WY/2WY AJiYMpiYZZiYmJiYy5iY/5iYAMuYMsuYZcuYmMuYy8uY/8uYAP+YMv+YZf+YmP+Yy/+Y///L AADLMgDLZQDLmADLywDL/wDLADLLMjLLZTLLmDLLyzLL/zLLAGXLMmXLZWXLmGXLy2XL/2XL AJjLMpjLZZjLmJjLy5jL/5jLAMvLMsvLZcvLmMvLy8vL/8vLAP/LMv/LZf/LmP/Ly//L//// AAD/MgD/ZQD/mAD/ywD//wD/ADL/MjL/ZTL/mDL/yzL//zL/AGX/MmX/ZWX/mGX/y2X//2X/ AJj/Mpj/ZZj/mJj/y5j//5j/AMv/Msv/Zcv/mMv/y8v//8v/AP//Mv//Zf//mP//y/////9E CiHUAAAAGUlEQVR4XmNgZMQPGBhHvoKRr2DkKxihCgBEmAQBphO0cAAAAABJRU5ErkJggg==' }! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:25'! decodeColors: colorsAndFiles depth: requiredDepth | color bytes form | colorsAndFiles do:[:assoc| color := assoc key. bytes := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. form := PNGReadWriter formFromStream: bytes. self assert: form depth = requiredDepth. self assert: (form pixelValueAt: 1@1) = (color pixelValueForDepth: requiredDepth). ].! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:30'! encodeColors: colorsAndFiles depth: requiredDepth | color original ff encoded | colorsAndFiles do:[:assoc| color := assoc key. original := Base64MimeConverter mimeDecodeToBytes: assoc value readStream. ff := Form extent: 32@32 depth: requiredDepth. ff fillColor: color. encoded := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: encoded. self assert: (encoded contents = original contents). ].! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors16 self decodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors32 self decodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors8 self decodeColors: self coloredFiles8 depth: 8.! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors16 self encodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors32 self encodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors8 self encodeColors: self coloredFiles8 depth: 8.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'! drawStuffOn: aForm "Draw stuff on aForm. Avoid any symmetry." | canvas | canvas := FormCanvas on: aForm. canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: Color red borderWidth: 3 borderColor: Color green. canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: Color blue borderWidth: 1 borderColor: Color white. ^aForm "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/11/2004 00:42'! drawTransparentStuffOn: aForm "Draw stuff on aForm. Avoid any symmetry." | canvas | canvas := FormCanvas on: aForm. canvas frameAndFillRectangle: (1@1 corner: aForm extent - 15) fillColor: (Color red alpha: 0.25) borderWidth: 3 borderColor: (Color green alpha: 0.5). canvas fillOval: (aForm boundingBox topRight - (15@-5) extent: 20@20) color: (Color white alpha: 0.75) borderWidth: 1 borderColor: Color blue. ^aForm "(PNGReadWriterTest new drawStuffOn: (Form extent: 32@32 depth: 16)) display"! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 4/17/2004 19:45'! encodeAndDecode: original "Make sure that the given form is encoded and decoded correctly" | stream bytes decoded maxErr | "encode" stream := ByteArray new writeStream. (PNGReadWriter on: stream) nextPutImage: original; close. bytes := stream contents. self writeEncoded: bytes. "decode" stream := self readEncoded: bytes. decoded := (PNGReadWriter new on: stream) nextImage. decoded display. "compare" self assert: original width = decoded width. self assert: original height = decoded height. self assert: original depth = decoded depth. self assert: original bits = decoded bits. self assert: original class == decoded class. (original isColorForm) ifTrue:[ original colors with: decoded colors do:[:c1 :c2| "we must round here due to encoding errors" maxErr := 1. "max. error for 8bit rgb component" self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. ]. ].! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:49'! encodeAndDecodeAlpha: original fileName := 'testAlpha', original depth printString,'.png'. self encodeAndDecode: original.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/18/2004 23:49'! encodeAndDecodeColor: aColor depth: aDepth | aForm | fileName := 'testColor', aColor name, aDepth printString,'.png'. aForm := Form extent: 32@32 depth: aDepth. aForm fillColor: aColor. self encodeAndDecode: aForm. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:02'! encodeAndDecodeDisplay: depth | form | fileName := 'testDisplay', depth printString,'.png'. form := Form extent: (Display extent min: 560@560) depth: depth. Smalltalk isMorphic ifTrue:[World fullDrawOn: form getCanvas] ifFalse:[Display displayOn: form]. self encodeAndDecode: form.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:50'! encodeAndDecodeForm: original fileName := 'testForm', original depth printString,'.png'. self encodeAndDecode: original.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 4/17/2004 19:45'! encodeAndDecodeReverse: original "Make sure that the given form is encoded and decoded correctly" | stream bytes decoded maxErr reversed | fileName := 'testReverse', original depth printString,'.png'. self assert: original class == Form. "won't work with ColorForm" "Switch pixel order" reversed := Form extent: original extent depth: original depth negated. original displayOn: reversed. self assert: original width = reversed width. self assert: original height = reversed height. self assert: original depth = reversed depth. self deny: original nativeDepth = reversed nativeDepth. original depth = 32 ifTrue:[self assert: original bits = reversed bits] ifFalse:[self deny: original bits = reversed bits]. "encode" stream := ByteArray new writeStream. (PNGReadWriter on: stream) nextPutImage: reversed; close. bytes := stream contents. self writeEncoded: bytes. "decode" stream := bytes readStream. decoded := (PNGReadWriter new on: stream) nextImage. decoded display. "compare" self assert: original width = decoded width. self assert: original height = decoded height. self assert: original depth = decoded depth. self assert: original bits = decoded bits. self assert: original class == decoded class. (original isColorForm) ifTrue:[ original colors with: decoded colors do:[:c1 :c2| "we must round here due to encoding errors" maxErr := 1. "max. error for 8bit rgb component" self assert: ((c1 red * 255) truncated - (c2 red * 255) truncated) abs <= maxErr. self assert: ((c1 green * 255) truncated - (c2 green * 255) truncated) abs <= maxErr. self assert: ((c1 blue * 255) truncated - (c2 blue * 255) truncated) abs <= maxErr. self assert: ((c1 alpha * 255) truncated - (c2 alpha * 255) truncated) abs <= maxErr. ]. ].! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 18:18'! encodeAndDecodeStream: file | aForm | file reset. (PNGReadWriter new on: file) understandsImageFormat ifFalse:[^self error: 'don''t understand format!!' ]. file reset. aForm := (PNGReadWriter new on: file) nextImage. aForm ifNil:[^self error: 'nil form' ]. aForm display. self encodeAndDecode: aForm. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:36'! encodeAndDecodeWithColors: aColorForm "Screw around with aColorForm colors" | colors nColors indexedColors max myRandom | fileName := 'testColors', aColorForm depth printString,'.png'. indexedColors := Color indexedColors. nColors := 1 bitShift: aColorForm depth. colors := WriteStream on: Array new. "Make first half translucent" max := nColors // 2. 1 to: max do:[:i| colors nextPut: ((indexedColors at: i) alpha: i / max asFloat). ]. "Make random choices for second half" myRandom := Random seed: 42315. max to: nColors do:[:i| colors nextPut: (indexedColors atRandom: myRandom). ]. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/29/2004 03:55'! encodeAndDecodeWithError: aStream self should:[self encodeAndDecodeStream: aStream] raise: Error! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:10'! readEncoded: bytes "Answer a ReadStream on the file named by fileName, if possible; else a ReadStream on bytes" fileName ifNil:[^ bytes readStream ]. ^(FileStream oldFileOrNoneNamed: fileName) ifNil: [ Transcript nextPutAll: 'can''t open ', fileName; cr. bytes readStream ]. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:45'! setUp fileName := nil.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:29'! tearDown World changed.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/12/2004 22:51'! writeEncoded: bytes | file | fileName ifNil:[^self]. false ifTrue:[^self]. file := FileStream forceNewFileNamed: fileName. [file nextPutAll: bytes] ensure:[file close].! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 17:19'! cleanLine "upTo LF or CR, tab as space" | line loop b | line _ WriteStream with: ''. loop _ true. [loop] whileTrue: [ b _ stream next. b ifNil:[ loop _ false "EOS" ] ifNotNil: [ (b = (Character cr) or:[b = Character lf]) ifTrue:[ loop _ false. ] ifFalse:[ b = (Character tab) ifTrue:[b _ Character space]. line nextPut: b. ] ] ]. ^line contents! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:20'! getTokenPbm: aCollection "get a number, return rest of collection" | line tokens token | tokens _ aCollection. tokens size = 0 ifTrue:[ [ line _ self pbmGetLine. line ifNil:[^{nil . nil}]. tokens _ line findTokens: ' '. tokens size = 0 ] whileTrue:[]. ]. "Transcript cr; show: tokens asString." token _ tokens removeFirst. ^{token asInteger . tokens} ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 16:39'! nextImage "read one image" | data p | first ifNil:[ first _ false. data _ stream contentsOfEntireFile. stream _ (RWBinaryOrTextStream with: data) reset. ] ifNotNil:[ type < 4 ifTrue:[ self error:'Plain PBM, PGM or PPM have only one image' ]. ]. stream ascii. p _ stream next. type _ (stream next) asInteger - 48. (p = $P and:[type > 0 and:[type < 8]]) ifFalse:[ self error:'Not a PNM file' ]. type = 7 ifTrue:[ self readHeaderPAM ] ifFalse: [ self readHeader ]. type caseOf: { [1] -> [^self readPlainBW]. [2] -> [^self readPlainGray]. [3] -> [^self readPlainRGB]. [4] -> [^self readBWreverse: false]. [5] -> [^self readGray]. [6] -> [^self readRGB]. [7] -> [ "PAM" (tupleType asUppercase) caseOf: { ['BLACKANDWHITE'] -> [^self readBWreverse: true]. ['GRAYSCALE'] -> [^self readGray]. ['RGB'] -> [^self readRGB]. ['RGB_ALPHA'] -> [^self error:'Not implemented']. ['GRAYSCALE_ALPHA'] -> [^self error:'Not implemented']. } otherwise: [^self readData]. ] }! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/10/2003 15:09'! pbmGetLine "Get the next non-comment line from the PBM stream Look for 'pragmas' - commands hidden in the comments" | line | [ line _ self cleanLine. line ifNil: [^nil]. (line size > 0 and:[(line at: 1) = $#]) ifTrue:[ self pbmParam: line. ]. (line size = 0) or:[(line at: 1) = $#] ] whileTrue: []. ^line! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/10/2003 15:11'! pbmParam: line "Look for a parameter hidden in a comment" | key tokens | tokens _ line findTokens: ' '. key _ (tokens at: 1) asLowercase. (key = '#origin' and:[tokens size = 3]) ifTrue:[ "ORIGIN key word" "This is for SE files as described in: Algoritms For Image Processing And Computer Vision. J. R. Parker" origin _ ((tokens at: 2) asInteger) @ ((tokens at: 3) asInteger) ]. ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/10/2003 17:17'! r: r g: g b: b for: depth "integer value according depth" | val | depth = 16 ifTrue: [ val _ (r << 10) + (g << 5) + b. ] ifFalse:[ val _ (r << 16) + (g << 8) + b. ]. ^val ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:49'! readBWreverse: flagXor "B&W for PAM" | val form bytesRow nBytes | stream binary. form _ Form extent: cols@rows depth: 1. nBytes _ (cols/8) ceiling. bytesRow _ (cols/32) ceiling * 4. 0 to: rows-1 do: [:y | | i | i _ 1 + (bytesRow*y). 0 to: nBytes-1 do: [:x | val _ stream next. flagXor ifTrue:[val _ val bitXor: 16rFF]. form bits byteAt: i put: val. i _ i+1. ] ]. ^form ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'md 10/20/2004 15:45'! readData "generic data" | data nBits nBytes val sample | stream binary. data _ OrderedCollection new. nBits _ maxValue floorLog:2. nBytes _ (nBits+1) >> 3. (nBits+1 rem: 8) > 0 ifTrue:[nBytes _ nBytes+1]. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | val _ 0. 1 to: nBytes do: [:n | sample _ stream next. val _ val << 8 + sample. ]. data add: val. ] ]. ^data ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:44'! readGray "gray form" | val form poker | maxValue > 255 ifTrue:[self error:'Gray value > 8 bits not supported in Squeak']. stream binary. form _ Form extent: cols@rows depth: depth. poker _ BitBlt current bitPokerToForm: form. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | val _ stream next. poker pixelAt: x@y put: val. ] ]. ^form ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 15:44'! readHeader "read header for pbm, pgm or ppm" | tokens aux d c | tokens _ OrderedCollection new. aux _ self getTokenPbm: tokens. cols _ aux at: 1. tokens _ aux at: 2. aux _ self getTokenPbm: tokens. rows _ aux at: 1. tokens _ aux at: 2. (type = 1 or:[type = 4]) ifTrue:[ maxValue _ 1 ] ifFalse: [ aux _ self getTokenPbm: tokens. maxValue _ aux at: 1. tokens _ aux at: 2. ]. d _ {1 . 2 . 4 . 8 . 16 . 32}. c _ {2 . 4 . 16 . 256 . 32768 . 16777216}. (type = 3 or:[type = 6]) ifTrue: [ maxValue >= 65536 ifTrue:[ self error:'Pixmap > 48 bits not supported in PPM' ]. maxValue >= 256 ifTrue:[ self error:'Pixmap > 32 bits are not supported in Squeak' ]. maxValue < 32 ifTrue:[depth _ 16] ifFalse:[depth _ 32]. ] ifFalse: [ depth _ nil. 1 to: c size do:[:i| ((c at: i) > maxValue and:[depth = nil]) ifTrue:[depth_d at: i]]. ]. Transcript cr; show: 'PBM file class ', type asString, ' size ', cols asString, ' x ', rows asString, ' maxValue =', maxValue asString, ' depth=', depth asString. ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:35'! readHeaderPAM "read pam header, not tested" | loop line tokens key val | tupleType _ ''. loop _ true. loop whileTrue:[ line _ self pbmGetLine. tokens _ line findTokens: ' '. tokens size = 2 ifTrue:[ key _ tokens at: 1 asUppercase. val _ tokens at: 2. key caseOf: { ['WIDTH'] -> [cols _ val asInteger]. ['HEIGHT'] -> [rows _ val asInteger]. ['DEPTH'] -> [depth _ val asInteger]. ['MAXVAL'] -> [maxValue _ val asInteger]. ['TUPLETYPE'] -> [tupleType _ tupleType, ' ', val]. ['ENDHDR'] -> [loop _ false]. } ] ]. Transcript cr; show: 'PAM file class ', type asString, ' size ', cols asString, ' x ', rows asString, ' maxValue =', maxValue asString, ' depth=', depth asString. ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 16:03'! readPlainBW "plain BW" | val form poker | form _ Form extent: cols@rows depth: depth. poker _ BitBlt current bitPokerToForm: form. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | [val _ stream next. (val = $0 or:[val = $1])] whileFalse:[ val ifNil:[self error:'End of file reading PBM']. ]. poker pixelAt: x@y put: (val asInteger). ] ]. ^form ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/16/2003 15:44'! readPlainGray "plain gray" | val form poker aux tokens | form _ Form extent: cols@rows depth: depth. poker _ BitBlt current bitPokerToForm: form. tokens _ OrderedCollection new. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | aux _ self getTokenPbm: tokens. val _ aux at: 1. tokens _ aux at: 2. poker pixelAt: x@y put: val. ] ]. ^form ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:49'! readPlainRGB "RGB form, use 32 bits" | val form poker tokens aux | maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak']. form _ Form extent: cols@rows depth: 32. poker _ BitBlt current bitPokerToForm: form. tokens _ OrderedCollection new. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | | r g b| aux _ self getTokenPbm: tokens. r _ aux at: 1. tokens _ aux at: 2. aux _ self getTokenPbm: tokens. g _ aux at: 1. tokens _ aux at: 2. aux _ self getTokenPbm: tokens. b _ aux at: 1. tokens _ aux at: 2. val _ self r: r g: g b: b for: depth. poker pixelAt: x@y put: val. ] ]. ^form ! ! !PNMReadWriter methodsFor: 'reading' stamp: 'jdr 10/15/2003 12:48'! readRGB "RGB form, use 16/32 bits" | val form poker sample shift | maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not supported in Squeak']. stream binary. form _ Form extent: cols@rows depth: depth. poker _ BitBlt current bitPokerToForm: form. depth = 32 ifTrue:[shift _ 8] ifFalse:[shift _ 5]. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | val _ 0. 1 to: 3 do: [:i | sample _ stream next. val _ val << shift + sample. ]. poker pixelAt: x@y put: val. ] ]. ^form ! ! !PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'! nextPutBW: aForm reverse: flagXor | myType val nBytes bytesRow | cols _ aForm width. rows _ aForm height. depth _ aForm depth. "stream position: 0." aForm depth = 1 ifTrue:[myType _ $4] ifFalse:[myType _ $5]. self writeHeader: myType. stream binary. nBytes _ (cols/8) ceiling. bytesRow _ (cols/32) ceiling * 4. 0 to: rows-1 do: [:y | | i | i _ 1 + (bytesRow*y). 0 to: nBytes-1 do: [:x | val _ aForm bits byteAt: i. flagXor ifTrue:[val _ val bitXor: 16rFF]. stream nextPut: val. i _ i+1. ] ]. ! ! !PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'! nextPutGray: aForm | myType peeker val | cols _ aForm width. rows _ aForm height. depth _ aForm depth. "stream position: 0." aForm depth = 1 ifTrue:[myType _ $4] ifFalse:[myType _ $5]. self writeHeader: myType. peeker _ BitBlt current bitPeekerFromForm: aForm. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | val _ peeker pixelAt: x@y. stream nextPut: val. ] ]. ! ! !PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 14:22'! nextPutImage: aForm aForm unhibernate. aForm depth caseOf: { [1] -> [self nextPutBW: aForm reverse: false]. [16] -> [self nextPutRGB: aForm]. [32] -> [self nextPutRGB: aForm]. } otherwise: [ (aForm respondsTo: #colors) ifTrue:[ aForm colors ifNil: [ self nextPutGray: aForm ] ifNotNil: [ self nextPutRGB: aForm ] ] ifFalse:[ self nextPutGray: aForm ] ]! ! !PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/16/2003 16:08'! nextPutRGB: aForm | myType peeker f shift mask | cols _ aForm width. rows _ aForm height. depth _ aForm depth. f _ aForm. depth < 16 ifTrue:[ f _ aForm asFormOfDepth: 32. depth _ 32. ]. myType _ $6. "stream position: 0." self writeHeader: myType. depth = 32 ifTrue:[shift _ 8. mask _ 16rFF] ifFalse:[shift _ 5. mask _ 16r1F]. peeker _ BitBlt current bitPeekerFromForm: f. 0 to: rows-1 do: [:y | 0 to: cols-1 do: [:x | | p r g b | p _ peeker pixelAt: x@y. b _ p bitAnd: mask. p _ p >> shift. g _ p bitAnd: mask. p _ p >> shift. r _ p bitAnd: mask. stream nextPut: r. stream nextPut: g. stream nextPut: b. ] ]. ! ! !PNMReadWriter methodsFor: 'writing' stamp: 'jdr 10/15/2003 15:48'! writeHeader: myType "this is ascii" stream nextPut: ($P asciiValue). stream nextPut: (myType asciiValue). stream nextPut: 10. "nl" pragma ifNotNil:[ stream nextPutAll: (pragma asByteArray). ]. stream nextPutAll: (cols printString) asByteArray. stream nextPut: 32. " " stream nextPutAll: (rows printString) asByteArray. stream nextPut: 10. "nl" depth > 1 ifTrue: [| d c maxV | d _ {1 . 2 . 4 . 8 . 16 . 32}. c _ {1 . 3 . 15 . 255 . 31 . 255}. maxV _ nil. 1 to: d size do:[:i| ((d at: i) = depth and:[maxV = nil]) ifTrue:[maxV _ c at: i]]. stream nextPutAll: (maxV printString) asByteArray. stream nextPut: 10. "nl" ] ! ! !PNMReadWriter methodsFor: 'testing' stamp: 'jdr 10/11/2003 14:52'! understandsImageFormat "P1 to P7" | p | p _ stream next asCharacter. type _ stream next - 48. ^(p = $P and:[type > 0 and:[type < 8]]) ! ! !PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:52'! origin ^origin! ! !PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/15/2003 15:35'! pragma: s pragma _ s! ! !PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/10/2003 18:04'! stream: s stream _ s! ! !PNMReadWriter methodsFor: 'accessing' stamp: 'jdr 10/16/2003 14:53'! tupleType ^tupleType! ! !PNMReadWriter commentStamp: 'jdr 10/20/2003 17:08' prior: 0! I am a subclass of ImageReadWriter that decodes portable anymap file formats (pbm, pgm, ppm and pam) images. I accept the #origin pragma for SE files as described in: Algoritms For Image Processing And Computer Vision. J. R. Parker Don't work with 2 bytes samples (16 bit grays, > 32 bits color, etc...), pam files preliminary support. f _ ImageReadWriter formFromFileNamed: 'Tools:Squeak3.4:Carmen.ppm'. f morphEdit Submitted by Javier Diaz Reinoso, Oct/2003! ]style[(361 18 2 26 3 11 1 43)f1,cblack;f1,f1b,f1,f1b,f1,f1b,f1! !PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/11/2003 14:49'! testFromSEFile: filename "read SE file, check origin PNMReadWriter testFromSEFile: 'Tools:Squeak3.4:eliseSE.pbm'. " | prw f | prw _ self new. prw stream: (FileStream readOnlyFileNamed: filename). f _ prw nextImage. f morphEdit. prw inspect! ! !PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/16/2003 17:22'! testFromString "read SE file from string PNMReadWriter testFromString " | prw f s | prw _ self new. s _ 'P1 #origin 1 0 3 1 1 01'. prw stream: (ReadStream on: s from: 1 to: (s size)). f _ prw nextImage. f morphEdit. Transcript cr;show:'Origin=', prw origin asString; cr.! ! !PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/20/2003 17:05'! testMultiFile: filename "write two files from user, then read PNMReadWriter testMultiFile: 'Tools:Squeak3.6:outMulti.pbm'. " | prw f | prw _ self new. prw stream: ((FileStream newFileNamed: filename) binary). prw pragma: '#Squeak test', String lf. f _ Form fromUser. prw nextPutImage: f. f _ Form fromUser.prw nextPutImage: f. prw close. prw stream: (FileStream readOnlyFileNamed: filename). f _ prw nextImage. (SketchMorph withForm: f) openInWorld. f _ prw nextImage. (SketchMorph withForm: f) openInWorld. ! ! !PNMReadWriter class methodsFor: 'testing' stamp: 'jdr 10/15/2003 15:43'! testToSEFile: filename "write SE file with origin PNMReadWriter testToSEFile: 'Tools:Squeak3.4:outSE.pbm'. " | prw f | prw _ self new. prw stream: ((FileStream newFileNamed: filename) binary). prw pragma: '#origin 10 10', String lf. f _ Form fromUser. prw nextPutImage: f! ! !PNMReadWriter class methodsFor: 'image reading/writing' stamp: 'st 9/18/2004 23:47'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('pnm')! ! !POP3Client methodsFor: 'private' stamp: 'mir 11/11/2002 16:20'! loginMethod ^self connectionInfo at: #loginMethod ifAbsent: [nil]! ! !POP3Client methodsFor: 'private' stamp: 'mir 3/8/2002 11:41'! loginMethod: aSymbol ^self connectionInfo at: #loginMethod put: aSymbol! ! !POP3Client methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:43'! responseIsError ^self lastResponse beginsWith: '-'! ! !POP3Client methodsFor: 'private testing' stamp: 'mir 11/11/2002 15:44'! responseIsWarning ^self lastResponse beginsWith: '-'! ! !POP3Client methodsFor: 'private protocol' stamp: 'mdr 9/3/2003 16:52'! apopLogin "Attempt to authenticate ourselves to the server without sending the password as cleartext." "For secure authentication, we look for a timestamp in the initial response string we get from the server, and then try the APOP command as specified in RFC 1939. If the initial response from the server is +OK POP3 server ready <1896.697170952@dbc.mtview.ca.us> we extract the timestamp <1896.697170952@dbc.mtview.ca.us> then form a string of the form <1896.697170952@dbc.mtview.ca.us>USERPASSWORD and then send only the MD5 hash of that to the server. Thus the password never hits the wire" | timestamp hash | [ "Look for a timestamp in the response we received from the server" timestamp _ self lastResponse findTokens: '<>' includes: '@'. timestamp ifNil: [(POP3LoginError protocolInstance: self) signal: 'APOP not supported.']. (Smalltalk includesKey: #MD5) ifTrue: [ hash _ ((Smalltalk at: #MD5) hashMessage: ('<', timestamp, '>', self password)) hex asLowercase. "trim starting 16r and zero pad it to 32 characters if needed" hash _ (hash allButFirst: 3) padded: #left to: 32 with: $0] ifFalse: [(POP3LoginError protocolInstance: self) signal: 'APOP (MD5) not supported.']. self sendCommand: 'APOP ', self user, ' ', hash. self checkResponse. self logProgress: self lastResponse] on: ProtocolClientError do: [:ex | self close. (LoginFailedException protocolInstance: self) signal: 'Login failed.']! ! !POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:38'! clearTextLogin [self sendCommand: 'USER ', self user. self checkResponse. self logProgress: self lastResponse. self sendCommand: 'PASS ', self password. self checkResponse. self logProgress: self lastResponse] on: TelnetProtocolError do: [:ex | "Neither authentication worked. Indicate an error and close up" self close. ex resignalAs: ((LoginFailedException protocolInstance: self) signal: 'Login failed.')]! ! !POP3Client methodsFor: 'private protocol' stamp: 'mir 11/14/2002 17:40'! getMultilineResponse "Get a multiple line response to the last command, filtering out LF characters. A multiple line response ends with a line containing only a single period (.) character." | response done chunk | response _ WriteStream on: ''. done _ false. [done] whileFalse: [ chunk _ self stream nextLine. (chunk beginsWith: '.') ifTrue: [response nextPutAll: (chunk copyFrom: 2 to: chunk size); cr ] ifFalse: [response nextPutAll: chunk; cr ]. done _ (chunk = '.') ]. ^ response contents ! ! !POP3Client methodsFor: 'private protocol' stamp: 'mir 4/7/2003 17:39'! login self loginMethod ifNil: [^self]. self loginMethod == #clearText ifTrue: [^self clearTextLogin]. self loginMethod == #APOP ifTrue: [^self apopLogin]. (POP3LoginError protocolInstance: self) signal: 'Unsupported login procedure.'! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:58'! apopLoginUser: userName password: password self loginUser: userName password: password loginMethod: #APOP! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! deleteMessage: num "delete the numbered message" self ensureConnection. self sendCommand: 'DELE ', num printString. self checkResponse. self logProgress: self lastResponse! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:57'! loginUser: userName password: password self loginUser: userName password: password loginMethod: #clearText! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/8/2002 11:40'! loginUser: userName password: password loginMethod: aLoginMethod self user: userName. self password: password. self loginMethod: aLoginMethod. self login! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 4/7/2003 17:17'! messageCount "Query the server and answer the number of messages that are in the user's mailbox." | answerString numMessages | self ensureConnection. self sendCommand: 'STAT'. self checkResponse. self logProgress: self lastResponse. [answerString _ (self lastResponse findTokens: Character separators) second. numMessages _ answerString asNumber asInteger] on: Error do: [:ex | (ProtocolClientError protocolInstance: self) signal: 'Invalid STAT response.']. ^numMessages! ! !POP3Client methodsFor: 'public protocol' stamp: 'len 12/14/2002 17:50'! quit "QUIT <CRLF>" self sendCommand: 'QUIT'. self checkResponse.! ! !POP3Client methodsFor: 'public protocol' stamp: 'mir 3/7/2002 14:35'! retrieveMessage: number "retrieve the numbered message" self ensureConnection. self sendCommand: 'RETR ', number printString. self checkResponse. self logProgress: self lastResponse. ^self getMultilineResponse! ! !POP3Client commentStamp: 'mir 5/12/2003 17:57' prior: 0! This class implements POP3 (Post Office Protocol 3) as specified in RFC 1939. (see http://www.ietf.org/rfc.html) You can use it to download email from the mail server to your personal mail program. To see an example of it's use, see POPSocket class>>example.! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:51'! defaultPortNumber ^110! ! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:52'! logFlag ^#pop! ! !POP3Client class methodsFor: 'example' stamp: 'mir 11/11/2002 16:52'! example "POP3Client example" "download a user's messages into an OrderedCollection and inspect the OrderedCollection" | ps messages userName password | userName := (FillInTheBlank request: 'POP username'). password := (FillInTheBlank request: 'POP password'). ps _ POP3Client openOnHostNamed: (FillInTheBlank request: 'POP server'). [ ps loginUser: userName password: password. ps logProgressToTranscript. messages _ OrderedCollection new. 1 to: ps messageCount do: [ :messageNr | messages add: (ps retrieveMessage: messageNr) ]] ensure: [ps close]. messages inspect.! ! !POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0! Exception for signaling POP3 login failures.! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 07:35'! directories "answer the receiver's directories" ^ directories! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:44'! directory "answer the receiver's directory" | result | result := String new writeStream. self directories do: [:each | result nextPutAll: each] separatedBy: [result nextPutAll: self slash]. ^ result contents! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 21:01'! directoryWrapperClass "answer the class to be used as a wrapper in FileList2" ^ FileDirectoryWrapper! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:44'! downloadUrl "The url under which files will be accessible." ^ (self urlFromServer: self server directories: {'programmatic'}) , self slash! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/27/2003 11:06'! moniker "a plain language name for this directory" ^ self server! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 20:53'! realUrl "a fully expanded version of the url we represent." ^self urlFromServer: self server directories: self directories! ! !PRServerDirectory methodsFor: 'accessing' stamp: 'dgd 12/22/2003 07:40'! server "answer the receiver's server" ^ server! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:25'! createDirectory: localName "Create a new sub directory within the current one" ^ self inform: 'operation not supported' translated! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:24'! deleteFileNamed: localFileName "Delete the file with the given name in this directory." ^ self inform: 'operation not supported' translated! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:45'! directoryNamed: aString "Return the subdirectory of this directory with the given name." ^ self class server: self server directory: self directory , self slash, aString! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 21:30'! directoryNames "Return a collection of names for the subdirectories of this directory. " ^ self entries select: [:entry | entry isDirectory] thenCollect: [:entry | entry name]! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:40'! entries "Return a collection of directory entries for the files and directories in this directory." | lines | lines := self getLines. ^ lines isNil ifTrue: [#()] ifFalse:[ self parseLines: lines]! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 21:30'! fileNames "Return a collection of names for the files (but not directories) in this directory." ^ self entries select: [:entry | entry isDirectory not] thenCollect: [:entry | entry name]! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:30'! fullNameFor: aString "Return a corrected, fully-qualified name for the given file name." ^ self urlFromServer: self server directories: self directories , {aString}! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/27/2003 12:36'! getOnly: numberOfBytes from: fileNameOnServer "Just capture the first numberOfBytes of the file. Goes faster for long files. Return the contents, not a stream." | fileName | self flag: #todo. "use LRUCache" fileName := fileNameOnServer allButFirst: (fileNameOnServer lastIndexOf: self pathNameDelimiter). "" ^ self getOnly: numberOfBytes ofProjectContents: fileName! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:33'! oldFileNamed: aName "Open the existing file with the given name in this directory." ^ self oldFileOrNoneNamed: aName! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/27/2003 11:35'! oldFileOrNoneNamed: fullName "If the file exists, answer a read-only FileStream on it. If it doesn't, answer nil." | fileName contents | fileName := fullName allButFirst: (fullName lastIndexOf: self pathNameDelimiter). "" contents := self getFullProjectContents: fileName. contents isNil ifTrue: [^ nil]. "" ^ (SwikiPseudoFileStream with: contents) directory: self; localName: fileName; reset; yourself! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 07:58'! on: fullName "Answer another ServerDirectory on the partial path name. fullName is directory path, and does include the name of the server." ^ self class fullPath: fullName! ]style[(4 8 3 133 4 4 17 8)f3b,f3cblue;b,f3,f3c147045000,f3,f3cmagenta;,f3,f3cblue;i! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:39'! pathName"Path name as used in reading the file. " ^ self urlFromServer: self server directories: self directories! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 08:08'! pathParts "Return the path from the root of the file system to this directory as an array of directory names. On a remote server." ^ (OrderedCollection with: self server) addAll: self directories; yourself! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:34'! readOnlyFileNamed: aName "Open the existing file with the given name in this directory for read-only access." ^ self oldFileNamed: aName! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:26'! rename: fullName toBe: newName "Rename a remote file. fullName is just be a fileName, or can be directory path that includes name of the server. newName is just a fileName" ^ self inform: 'operation not supported' translated! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:37'! sleep"Leave the FileList window. Do nothing. " ^ self! ! !PRServerDirectory methodsFor: 'file directory' stamp: 'dgd 12/22/2003 20:32'! wakeUp"Entering a FileList window. Do nothing." ^ self! ! !PRServerDirectory methodsFor: 'initialization' stamp: 'dgd 12/22/2003 20:46'! initializeServer: serverString directories: directoriesCollection "initialize the receiver's server and directories" server := serverString withBlanksTrimmed. server last = self pathNameDelimiter ifTrue: [server := server allButLast withBlanksTrimmed]. "" directories := directoriesCollection! ! !PRServerDirectory methodsFor: 'path access' stamp: 'dgd 12/22/2003 20:41'! pathNameDelimiter"Return the delimiter character for this kind of directory." ^ $/! ! !PRServerDirectory methodsFor: 'path access' stamp: 'dgd 12/22/2003 20:44'! slash "answer the recevier 'slash'" ^ self pathNameDelimiter asString! ! !PRServerDirectory methodsFor: 'squeaklets' stamp: 'dgd 12/25/2003 14:34'! writeProject: aProject inFileNamed: fileNameString fromDirectory: localDirectory "write aProject (a file version can be found in the file named fileNameString in localDirectory)" | url arguments answer string | url := self urlFromServer: self server directories: {'programmatic'. 'uploadproject'}. arguments := self getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory. "" Cursor read showWhile: ["" "answer := HTTPClient httpPostDocument: url args: args." answer := HTTPSocket httpGetDocument: url args: arguments. string := answer contents. (string beginsWith: '--OK--') ifTrue: [^ true]]. "" self inform: ('Server responded: {1}' translated format: {string}). ^ false! ! !PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/22/2003 20:39'! acceptsUploads "answer whatever the receiver accepts uploads" ^ true! ! !PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/22/2003 00:42'! isProjectSwiki "answer whatever the receiver is a project swiki" ^ true! ! !PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/27/2003 11:04'! isRemoteDirectory "answer whatever the receiver is a remote directory" ^ true! ! !PRServerDirectory methodsFor: 'testing' stamp: 'dgd 12/21/2003 23:31'! isSearchable "answer whatever the receiver is searchable" ^ true! ! !PRServerDirectory methodsFor: 'testing' stamp: 'dgd 8/17/2004 22:14'! queryProjectsAndShow: thingsToSearchForCollection "query the server for all the projects that match thingsToSearchForCollection" | url arguments answer string | url := self urlFromServer: self server directories: {'programmatic'. 'queryprojects'}. arguments := self getPostArgsFromThingsToSearchFor: thingsToSearchForCollection. "" Cursor read showWhile: ["" "answer := HTTPClient httpPostDocument: url args: args." answer := HTTPSocket httpGetDocument: url args: arguments. string := answer contents. (string beginsWith: '--OK--') ifTrue: [^ true]]. "" self inform: ('Server responded: {1}' translated format: {string}). ^ false! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/27/2003 11:34'! getFullProjectContents: aString "private - get the project content from the server" ^ self getOnly: nil ofProjectContents: aString! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 8/17/2004 22:23'! getLines "private - answer a collection of lines with the server response" | url answer string lines | url := self urlFromServer: self server directories: {'programmatic'} , self directories. url := url , self slash. "" Cursor read showWhile: ["" answer := HTTPClient httpGetDocument: url. string := answer contents. (string beginsWith: '--OK--') ifFalse: [^ nil]]. "" lines := OrderedCollection new. (string allButFirst: 6) linesDo: [:line | lines add: line squeakToIso]. "" ^ lines! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/27/2003 12:37'! getOnly: numberOfBytes ofProjectContents: aString "private - get numberOfBytes of the project contents" | url answer contents args | self flag: #todo. "use an LRUCache" url := self urlFromServer: self server directories: {'programmatic'. aString}. "" args := numberOfBytes isNil ifFalse: ['numberOfBytes=' , numberOfBytes asString]. "" Cursor read showWhile: ["" answer := HTTPSocket httpGetDocument: url args: args. contents := answer contents]."" (contents beginsWith: '--OK--') ifFalse: [^ nil]. "" ^ contents allButFirst: 6! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 10/7/2004 20:55'! getPostArgsFromProject: aProject fileNamed: fileNameString fromDirectory: localDirectory | args thumbnail uploader | args := Dictionary new. "" args at: 'contents' put: {(localDirectory oldFileNamed: fileNameString) contentsOfEntireFile}. "" args at: 'name' put: {aProject name isoToSqueak}. args at: 'version' put: {(Project parseProjectFileName: fileNameString) second asString}. args at: 'language' put: {aProject naturalLanguage asString}. "" uploader := Utilities authorNamePerSe. uploader isEmptyOrNil ifTrue: [uploader := Utilities authorInitialsPerSe]. uploader isEmptyOrNil ifFalse: [args at: 'uploader' put: {uploader}]. "" self putSmalltalkInfoInto: args. "" thumbnail := self getProjectThumbnail: aProject. thumbnail isNil ifFalse: [args at: 'thumbnailcontents' put: {thumbnail}]. "" self putProjectDetailsFrom: aProject to: args. "" ^ args! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 8/17/2004 22:14'! getPostArgsFromThingsToSearchFor: thingsToSearchForCollection | args | args := Dictionary new. "" thingsToSearchForCollection do: [:each | | pos | pos := each indexOf: $:. pos isZero ifFalse: [| key value | key := (each first: pos - 1) withBlanksTrimmed. value := (each allButFirst: pos) withBlanksTrimmed. (value beginsWith: '*') ifTrue: [value := value allButFirst]. (value endsWith: '*') ifTrue: [value := value allButLast]. "" args at: key put: {value}]]. "" ^ args! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/24/2003 11:33'! getProjectThumbnail: aProject "private - answer a stream with the aProject's thumbnail or nil if none" | form stream | form := aProject thumbnail. form isNil ifTrue: [^ nil]. "" form unhibernate. form := form colorReduced. "" self flag: #todo. "use a better image format than GIF" stream := RWBinaryOrTextStream on: String new. GIFReadWriter putForm: form onStream: stream. stream reset. "" ^ stream contents asString! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:34'! parseLine: aString "private - parse a line from a server response" | tokens | tokens := aString findTokens: '|'. "" ^ tokens first = 'D' ifTrue: ["" DirectoryEntry name: tokens second creationTime: 0 modificationTime: 0 isDirectory: true fileSize: 0] ifFalse: ["" DirectoryEntry name: tokens second creationTime: tokens third asInteger modificationTime: tokens fourth asInteger isDirectory: false fileSize: tokens fifth asInteger]! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:38'! parseLines: aCollection "private - parse aCollection of lines from a server response" ^ aCollection collect: [:each | self parseLine: each]! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/24/2003 11:35'! putProjectDetailsFrom: aProject to: args | projectDetails | projectDetails := aProject world valueOfProperty: #ProjectDetails ifAbsent: [^ self]."" self flag: #todo. "projectname ?" projectDetails at: 'projectdescription' ifPresent: [:value | args at: 'description' put: {value}]. projectDetails at: 'projectauthor' ifPresent: [:value | args at: 'author' put: {value}]. projectDetails at: 'projectcategory' ifPresent: [:value | args at: 'category' put: {value}]. projectDetails at: 'projectsubcategory' ifPresent: [:value | args at: 'subcategory' put: {value}]. projectDetails at: 'projectkeywords' ifPresent: [:value | args at: 'keywords' put: {value}]! ! !PRServerDirectory methodsFor: 'private' stamp: 'nk 7/29/2004 10:02'! putSmalltalkInfoInto: args "private - fills args with information from Smalltalk" self flag: #todo. " lastest small-land changeset / small-land version " #(#datedVersion #osVersion #platformName #platformSubtype #vmPath #vmVersion #imageName #changesName #sourcesName #listBuiltinModules #listLoadedModules #getVMParameters ) do: [:each | | value | value := SmalltalkImage current perform: each. args at: 'extra-' , each asString put: {value asString}]! ! !PRServerDirectory methodsFor: 'private' stamp: 'dgd 12/22/2003 20:47'! urlFromServer: serverString directories: aCollection "private - builds an url for server/directories" | result | result := String new writeStream. "" {serverString} , aCollection do: [:each | "" result nextPutAll: (each copyReplaceAll: ' ' with: '+')] separatedBy: [result nextPutAll: self slash]. "" ^ result contents! ! !PRServerDirectory commentStamp: 'md 1/26/2004 12:40' prior: 0! Add support to publish or download projects from Small-Land Project Repository (SLPR). The SLPR has virtual folders where the projects appears. The SLPR can be acceded from the FileList or from the web interface at http://repository.small-land.org:8080 Basically it's a type of superswiki (but better ;)). The features in SMPR not present in SuperSwiki are: - Both the web interface and the squeak-side interface are full translatable. The server has translations for English and Spanish just now, but it's almost trivial to include other translations... Stef? Marcus? ;) - The projects are categorized in "virtual" folder. These folders (By Category, By Author, By Language, Alphabetical, etc) give us good searching behaviour just using the FileList and mouse clicks. - The web interface (also full translatable) has a search a la google. - All the urls to query the web interface are "clean enough" so google can make a good job indexing our content in .pr files. It's planned to add "editing" features to the web interface to re-categorize, remove, etc projects. Enjoy it, -- Diego Gomez Deck http://www.small-land.org! !PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 20:43'! fullPath: fullNameString "answer an instance of the receiver on fullName" | pathParts | pathParts := self pathParts: fullNameString. ^ self server: pathParts first directories: pathParts allButFirst! ! !PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 20:43'! pathParts: fullName "private - parse fullName in server and directory" | url slashPos server directory | url := fullName. (url beginsWith: 'http://') ifTrue: [url := url allButFirst: 7]. url last = $/ ifTrue: [url := url allButLast]. "" slashPos := url indexOf: $/. slashPos isZero ifTrue: [^ {'http://' , url}]. "" server := url first: slashPos - 1. directory := url allButFirst: slashPos. "" ^ {'http://' , server. directory}! ! !PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:57'! server: serverString "answer a new instance of the receiver on server aString" ^ self server: serverString directories: #()! ! !PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:56'! server: serverString directories: aCollection "answer a new instance of the receiver on server aString" ^ self new initializeServer: serverString directories: aCollection! ! !PRServerDirectory class methodsFor: 'instance creation' stamp: 'dgd 12/22/2003 07:58'! server: serverString directory: directoryString "answer a new instance of the receiver on server aString" ^ self new initializeServer: serverString directories: (directoryString findTokens: '/')! ]style[(8 12 12 15 3 57 4 4 25 12 17 15 13 3 1)f3b,f3cblue;b,f3b,f3cblue;b,f3,f3c147045000,f3,f3cmagenta;,f3,f3cblue;i,f3,f3cblue;i,f3,f3c255147000b,f3! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 3/9/2004 15:53'! category: categoryName matches: prefix ^ categoryName notNil and: [categoryName = prefix or: [categoryName beginsWith: prefix, '-']]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:18'! coreCategoriesForClass: aClass ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! coreMethodsForClass: aClass ^ (aClass selectors difference: ((self foreignExtensionMethodsForClass: aClass) collect: [:r | r methodSymbol])) asArray collect: [:sel | self referenceForMethod: sel ofClass: aClass]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:20'! extensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 4/6/2004 15:16'! extensionMethodsForClass: aClass ^ (self extensionCategoriesForClass: aClass) gather: [:cat | ((aClass organization listAtCategoryNamed: cat) ifNil: [#()]) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! extensionMethodsFromClasses: classes ^classes gather: [:class | self extensionMethodsForClass: class]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! foreignExtensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! foreignExtensionMethodsForClass: aClass ^ (self foreignExtensionCategoriesForClass: aClass) gather: [:cat | (aClass organization listAtCategoryNamed: cat) collect: [:sel | self referenceForMethod: sel ofClass: aClass]]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! includesClass: aClass ^ self includesSystemCategory: aClass theNonMetaClass category! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:08'! includesClassNamed: aClassName ^ self includesSystemCategory: ((SystemOrganization categoryOfElement: aClassName) ifNil: [^false])! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 12/5/2002 00:16'! includesMethod: aSymbol ofClass: aClass aClass ifNil: [^ false]. ^ self includesMethodCategory: ((aClass organization categoryOfElement: aSymbol) ifNil: [' ']) ofClass: aClass! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 9/17/2002 00:18'! includesMethodCategory: categoryName ofClass: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClass: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 7/23/2003 14:06'! includesMethodCategory: categoryName ofClassNamed: aClass ^ (self isYourClassExtension: categoryName) or: [(self includesClassNamed: aClass) and: [(self isForeignClassExtension: categoryName) not]]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/14/2002 18:06'! includesMethodReference: aMethodRef ^ self includesMethod: aMethodRef methodSymbol ofClass: aMethodRef actualClass! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! includesSystemCategory: categoryName ^ self category: categoryName matches: self systemCategoryPrefix! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! isForeignClassExtension: categoryName ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 11/10/2003 15:42'! isOverrideMethod: aMethodReference ^ aMethodReference category endsWith: '-override'! ! !PackageInfo methodsFor: 'testing' stamp: 'avi 3/10/2004 12:37'! isYourClassExtension: categoryName ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ! !PackageInfo methodsFor: 'testing' stamp: 'dvf 10/18/2002 23:22'! outsideClasses ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:25'! referenceForMethod: aSymbol ofClass: aClass ^ MethodReference new setStandardClass: aClass methodSymbol: aSymbol! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/17/2002 00:05'! categoryName |category| category _ self class category. ^ (category endsWith: '-Info') ifTrue: [category copyUpToLast: $-] ifFalse: [category]! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 21:22'! externalName ^ self packageName! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 6/10/2003 17:21'! methodCategoryPrefix ^ methodCategoryPrefix ifNil: [methodCategoryPrefix _ '*', self packageName asLowercase]! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 16:57'! packageName ^ packageName ifNil: [packageName _ self categoryName]! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/16/2002 16:56'! packageName: aString packageName _ aString! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'! systemCategoryPrefix ^ self packageName! ! !PackageInfo methodsFor: 'listing' stamp: 'ac 5/14/2003 16:23'! classes ^(self systemCategories gather: [:cat | (SystemOrganization listAtCategoryNamed: cat) collect: [:className | Smalltalk at: className]]) sortBy: [:a :b | a className <= b className]! ! !PackageInfo methodsFor: 'listing' stamp: 'dvf 9/17/2002 00:56'! classesAndMetaClasses | baseClasses | baseClasses := self classes. ^baseClasses , (baseClasses collect: [:c | c class])! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 11/13/2002 01:23'! coreMethods ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ! !PackageInfo methodsFor: 'listing' stamp: 'cwp 3/17/2004 21:32'! extensionClasses ^ self externalClasses reject: [:class | (self extensionCategoriesForClass: class) isEmpty]! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 6/10/2003 17:12'! extensionMethods ^ self externalClasses gather: [:class | self extensionMethodsForClass: class]! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 12/3/2002 14:38'! foreignClasses | s | s _ IdentitySet new. self foreignSystemCategories do: [:c | (SystemOrganization listAtCategoryNamed: c) do: [:cl | | cls | cls _ Smalltalk at: cl. s add: cls; add: cls class]]. ^ s! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 12/3/2002 14:34'! foreignSystemCategories ^ SystemOrganization categories reject: [:cat | self includesSystemCategory: cat] ! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 7/6/2003 21:49'! methods ^ (self extensionMethods, self coreMethods) select: [:method | method isValid and: [(#(DoIt DoItIn:) includes: method methodSymbol) not]]! ! !PackageInfo methodsFor: 'listing' stamp: 'avi 11/10/2003 15:35'! overrideMethods ^ self extensionMethods select: [:ea | self isOvverideMethod: ea]! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 11/14/2002 18:39'! selectors ^ self methods collect: [:ea | ea methodSymbol]! ! !PackageInfo methodsFor: 'listing' stamp: 'ab 11/11/2002 21:51'! systemCategories ^ SystemOrganization categories select: [:cat | self includesSystemCategory: cat]! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:16'! externalCallers ^ self externalRefsSelect: [:literal | literal isKindOf: Symbol] thenCollect: [:l | l].! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 6/10/2003 17:18'! externalClasses | myClasses | myClasses _ self classesAndMetaClasses. ^ Array streamContents: [:s | ProtoObject withAllSubclassesDo: [:class | (myClasses includes: class) ifFalse: [s nextPut: class]]]! ! !PackageInfo methodsFor: 'dependencies' stamp: 'avi 2/29/2004 13:38'! externalRefsSelect: selBlock thenCollect: colBlock | pkgMethods dependents refs extMethods otherClasses otherMethods classNames | classNames _ self classes collect: [:c | c name]. extMethods _ self extensionMethods collect: [:mr | mr methodSymbol]. otherClasses _ self externalClasses difference: self externalSubclasses. otherMethods _ otherClasses gather: [:c | c selectors]. pkgMethods _ self methods asSet collect: [:mr | mr methodSymbol]. pkgMethods removeAllFoundIn: otherMethods. dependents _ Set new. otherClasses do: [:c | c selectorsAndMethodsDo: [:sel :compiled | (extMethods includes: sel) ifFalse: [refs _ compiled literals select: selBlock thenCollect: colBlock. refs do: [:ea | ((classNames includes: ea) or: [pkgMethods includes: ea]) ifTrue: [dependents add: (self referenceForMethod: sel ofClass: c) -> ea]]]]]. ^ dependents! ! !PackageInfo methodsFor: 'dependencies' stamp: 'cwp 11/13/2002 00:24'! externalSubclasses | pkgClasses subClasses | pkgClasses _ self classes. subClasses _ Set new. pkgClasses do: [:c | subClasses addAll: (c allSubclasses)]. ^ subClasses difference: pkgClasses ! ! !PackageInfo methodsFor: 'dependencies' stamp: 'ab 11/18/2002 01:15'! externalUsers ^ self externalRefsSelect: [:literal | literal isVariableBinding] thenCollect: [:l | l key]! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/13/2003 15:40'! addCoreMethod: aMethodReference | category | category _ self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: category suppressIfDefault: false! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:17'! addExtensionMethod: aMethodReference | category | category _ self baseCategoryOfMethod: aMethodReference. aMethodReference actualClass organization classify: aMethodReference methodSymbol under: self methodCategoryPrefix, '-', category! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:16'! addMethod: aMethodReference (self includesClass: aMethodReference class) ifTrue: [self addCoreMethod: aMethodReference] ifFalse: [self addExtensionMethod: aMethodReference]! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/13/2003 15:39'! baseCategoryOfMethod: aMethodReference | oldCat oldPrefix tokens | oldCat _ aMethodReference category. ({ 'as yet unclassified'. 'all' } includes: oldCat) ifTrue: [ oldCat _ '' ]. tokens _ oldCat findTokens: '*-' keep: '*'. "Strip off any old prefixes" ((tokens at: 1 ifAbsent: [ '' ]) = '*') ifTrue: [ [ ((tokens at: 1 ifAbsent: [ '' ]) = '*') ] whileTrue: [ tokens removeFirst ]. oldPrefix _ tokens removeFirst asLowercase. [ (tokens at: 1 ifAbsent: [ '' ]) asLowercase = oldPrefix ] whileTrue: [ tokens removeFirst ]. ]. tokens isEmpty ifTrue: [^ 'as yet unclassified']. ^ String streamContents: [ :s | tokens do: [ :tok | s nextPutAll: tok ] separatedBy: [ s nextPut: $- ]]! ! !PackageInfo methodsFor: 'modifying' stamp: 'avi 10/11/2003 15:14'! removeMethod: aMethodReference! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'! = other ^ other species = self species and: [other packageName = self packageName]! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'! hash ^ packageName hash! ! !PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'! register PackageOrganizer default registerPackage: self! ! !PackageInfo commentStamp: '<historical>' prior: 0! Subclass this class to create new Packages.! !PackageInfo class methodsFor: 'packages access' stamp: 'nk 3/9/2004 10:49'! allPackages ^PackageOrganizer default packages! ! !PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/12/2003 23:00'! named: aString ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ! !PackageInfo class methodsFor: 'packages access' stamp: 'avi 11/11/2003 17:19'! registerPackageName: aString ^ PackageOrganizer default registerPackageNamed: aString! ! !PackageInfo class methodsFor: 'class initialization' stamp: 'avi 2/18/2004 00:46'! initialize self allSubclassesDo: [:ea | ea new register]! ! !PackageInfo class methodsFor: 'compatibility' stamp: 'avi 3/9/2004 16:28'! default ^ self allPackages detect: [:ea | ea class = self] ifNone: [self new register]! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:37'! buildList ^ PluggableListMorph on: self list: #packageList selected: #packageSelection changeSelected: #packageSelection: menu: #packageMenu:! ! !PackageList methodsFor: 'morphic' stamp: 'avi 2/18/2004 00:28'! buildWindow | window | window _ SystemWindow labelled: self label. window model: self. window addMorph: self buildList fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1)). ^ window! ! !PackageList methodsFor: 'morphic' stamp: 'avi 2/18/2004 00:28'! defaultBackgroundColor ^ Color white! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:28'! defaultExtent ^ 200@200! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:36'! label ^ 'Packages'! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:24'! openInWorld self packageOrganizer addDependent: self. self buildWindow openInWorldExtent: self defaultExtent! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 13:09'! packageContextMenu: aMenu aMenu addLine; add: 'remove package' action: #removePackage; addServices: PackageServices allServices for: selectedPackage extraLines: #()! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:10'! packageList ^ self packages collect: [:ea | ea packageName]! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:24'! packageMenu: aMenu aMenu defaultTarget: self; add: 'add package' action: #addPackage. selectedPackage ifNotNil: [self packageContextMenu: aMenu]. ^ aMenu! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:41'! packageSelection ^ self packages indexOf: selectedPackage! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/10/2003 22:41'! packageSelection: aNumber selectedPackage _ self packages at: aNumber ifAbsent: []. self changed: #packageSelection! ! !PackageList methodsFor: 'morphic' stamp: 'avi 10/11/2003 00:15'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (self respondsTo: selector) ifTrue: [^ self perform: selector] ifFalse: [^ otherTarget perform: selector]! ! !PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:26'! addPackage | packageName | packageName _ FillInTheBlank request: 'Package name:'. packageName isEmpty ifFalse: [selectedPackage _ self packageOrganizer registerPackageNamed: packageName. self changed: #packageSelection]! ! !PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:17'! packageOrganizer ^ PackageOrganizer default! ! !PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:24'! removePackage self packageOrganizer unregisterPackage: selectedPackage! ! !PackageList methodsFor: 'actions' stamp: 'avi 10/11/2003 00:23'! update: aSymbol aSymbol = #packages ifTrue: [packages _ nil. self changed: #packageList; changed: #packageSelection]! ! !PackageList methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 00:18'! packages ^ packages ifNil: [packages _ self packageOrganizer packages asSortedCollection: [:a :b | a packageName <= b packageName]]! ! !PackageList class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:43'! initialize TheWorldMenu registerOpenCommand: {'Package List'. {self. #open}}! ! !PackageList class methodsFor: 'as yet unclassified' stamp: 'avi 10/10/2003 22:38'! open ^ self new openInWorld! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! noPackageFound self error: 'No package found'! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 11/12/2003 23:08'! packageNamed: aString ifAbsent: errorBlock ^ packages at: aString ifAbsent: errorBlock! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! packageOfClass: aClass ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! packageOfClass: aClass ifNone: errorBlock ^ self packages detect: [:ea | ea includesClass: aClass] ifNone: errorBlock! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! packageOfMethod: aMethodReference ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! packageOfMethod: aMethodReference ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:01'! registerPackage: aPackageInfo packages at: aPackageInfo packageName put: aPackageInfo. self changed: #packages; changed: #packageNames. ! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:08'! registerPackageNamed: aString ^ self registerPackage: (PackageInfo named: aString)! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:08'! unregisterPackage: aPackageInfo packages removeKey: aPackageInfo packageName ifAbsent: []. self changed: #packages; changed: #packageNames. ! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:10'! unregisterPackageNamed: aString self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! ! !PackageOrganizer methodsFor: 'initializing' stamp: 'avi 11/12/2003 23:01'! initialize packages _ Dictionary new! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packageNames ^ packages keys! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packages ^ packages values! ! !PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 00:17'! default ^ default ifNil: [default _ self new]! ! !PackageOrganizer class methodsFor: 'as yet unclassified' stamp: 'avi 10/13/2003 15:25'! new ^ self basicNew initialize! ! !PackagePaneBrowser methodsFor: 'initialize-release' stamp: 'RAA 2/6/2001 12:50'! openAsMorphEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." "PackagePaneBrowser openBrowser" | listHeight window | listHeight _ 0.4. (window _ SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #packageList selected: #packageListIndex changeSelected: #packageListIndex: menu: #packageMenu: keystroke: #packageListKey:from:) frame: (0 @ 0 extent: 0.15 @ listHeight). window addMorph: self buildMorphicSystemCatList frame: (0.15 @ 0 extent: 0.2 @ listHeight). self addClassAndSwitchesTo: window at: (0.35 @ 0 extent: 0.25 @ listHeight) plus: 0. window addMorph: self buildMorphicMessageCatList frame: (0.6 @ 0 extent: 0.15 @ listHeight). window addMorph: self buildMorphicMessageList frame: (0.75 @ 0 extent: 0.25 @ listHeight). self addLowerPanesTo: window at: (0 @ listHeight corner: 1 @ 1) with: editString. window setUpdatablePanesFrom: #(#packageList #systemCategoryList #classList #messageCategoryList #messageList ). ^ window! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:35'! categoryExistsForPackage ^ self hasPackageSelected and: [(systemOrganizer categories indexOf: self package asSymbol) ~= 0] ! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:24'! hasPackageSelected ^ packageListIndex ~= 0! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'tween 8/27/2004 12:08'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." "PackageBrowser openBrowser" | packageListView systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView | self couldOpenInMorphic ifTrue: [^ self openAsMorphEditing: aString]. topView := StandardSystemView new model: self. topView borderWidth: 1. "label and minSize taken care of by caller" packageListView := PluggableListView on: self list: #packageList selected: #packageListIndex changeSelected: #packageListIndex: menu: #packageMenu:. packageListView window: (0 @ 0 extent: 20 @ 70). topView addSubView: packageListView. systemCategoryListView := PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu:. systemCategoryListView window: (20 @ 0 extent: 30 @ 70). topView addSubView: systemCategoryListView. classListView := PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu:shifted:. classListView window: (0 @ 0 extent: 50 @ 62). topView addSubView: classListView toRightOf: systemCategoryListView. switchView := self buildInstanceClassSwitchView. switchView borderWidth: 1. topView addSubView: switchView below: classListView. messageCategoryListView := PluggableListView on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:. messageCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageCategoryListView toRightOf: classListView. messageListView := PluggableListView on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. messageListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. self wantsAnnotationPane ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: packageListView. underPane _ annotationPane. y _ 110 - self optionalAnnotationHeight] ifFalse: [underPane _ packageListView. y _ 110]. self wantsOptionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView := MvcTextEditor default on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'JF 7/30/2003 12:25'! package "Answer the receiver's 'package'." ^ self hasPackageSelected ifFalse: [nil] ifTrue: [self packageList at: packageListIndex] ! ! !PackagePaneBrowser methodsFor: 'package list' stamp: 'nk 2/14/2004 15:09'! updatePackages "Update the contents of the package list." self editSelection: #none. self changed: #packageList. self changed: #package. self packageListIndex: 0 ! ! !PackagePaneBrowser methodsFor: 'system category list' stamp: 'JF 7/30/2003 12:23'! hasSystemCategorySelected ^ systemCategoryListIndex ~= 0! ! !PackagePaneBrowser methodsFor: 'class list' stamp: 'JF 7/30/2003 12:26'! classList "Answer an array of the class names of the selected category. Answer an empty array if no selection exists." ^ self hasSystemCategorySelected ifFalse: [self packageClasses] ifTrue: [systemOrganizer listAtCategoryNumber: (systemOrganizer categories indexOf: self selectedSystemCategoryName asSymbol)]! ! !PackagePaneBrowser methodsFor: 'class list' stamp: 'JF 7/30/2003 12:36'! packageClasses ^ self categoryExistsForPackage ifFalse: [Array new] ifTrue: [systemOrganizer listAtCategoryNumber: (systemOrganizer categories indexOf: self package asSymbol)]! ! !PackagePaneBrowser methodsFor: 'dragNDrop util' stamp: 'ls 6/22/2001 23:21'! dstCategoryDstListMorph: dstListMorph internal: internal | dropItem | ^ internal & (dstListMorph getListSelector == #systemCategoryList) ifTrue: [(dropItem _ dstListMorph potentialDropItem) ifNotNil: [(self package , '-' , dropItem) asSymbol]] ifFalse: [self selectedSystemCategoryName]! ! !PackagePaneBrowser class methodsFor: 'instance creation' stamp: 'sw 6/11/2001 17:39'! prototypicalToolWindow "Answer an example of myself seen in a tool window, for the benefit of parts-launching tools" | aWindow | aWindow _ self new openAsMorphEditing: nil. aWindow setLabel: 'Package Browser'. aWindow applyModelExtent. ^ aWindow ! ! !PackagePaneBrowser class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:39'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Package Browser' brightColor: #(1.0 1.0 0.6) pastelColor: #(0.976 0.976 0.835) helpMessage: 'A system browser with an extra pane at top-left for module.'! ! !PackagePaneBrowser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 20:12'! initialize self registerInFlapsRegistry; registerInAppRegistry.! ! !PackagePaneBrowser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 20:12'! registerInAppRegistry "Register the receiver in the SystemBrowser AppRegistry" SystemBrowser register: self.! ! !PackagePaneBrowser class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:15'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(PackagePaneBrowser prototypicalToolWindow 'Packages' 'Package Browser: like a System Browser, except that if has extra level of categorization in the top-left pane, such that class-categories are further organized into groups called "packages"') forFlapNamed: 'Tools']! ! !PackagePaneBrowser class methodsFor: 'class initialization' stamp: 'hpt 8/5/2004 20:12'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self]. SystemBrowser unregister: self.! ! !PackageServices methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 14:06'! seeClassSide! ! !PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 13:01'! allServices ^ ServiceClasses gather: [:ea | ea services]! ! !PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'! initialize ServiceClasses _ Set new! ! !PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'! register: aClass ServiceClasses add: aClass! ! !PackageServices class methodsFor: 'as yet unclassified' stamp: 'avi 10/11/2003 12:59'! unregister: aClass ServiceClasses remove: aClass! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'JMM 9/13/2004 09:08'! selectColor: evt "Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically." | r | locOfCurrent := evt cursorPoint - self topLeft. r := Rectangle center: locOfCurrent extent: 9 @ 9. locOfCurrent := locOfCurrent + (r amountToTranslateWithin: (8 @ 11 corner: (self image width-6) @ (self image height-6))). locOfCurrent x > (self image width-(12+7)) ifTrue: [locOfCurrent := (self image width - 12) @ locOfCurrent y]. "snap into grayscale" currentColor := locOfCurrent y < 19 ifTrue: [locOfCurrent := locOfCurrent x @ 11. "snap into transparent" Color transparent] ifFalse: [image colorAt: locOfCurrent]. (owner isKindOf: PaintBoxMorph) ifTrue: [owner takeColorEvt: evt from: self]. self changed! ! !PaintBoxColorPicker commentStamp: 'JMM 9/13/2004 07:37' prior: 0! A pop-up, 32-bit color palette used as part of a PaintBoxMorph. ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! brush: brushButton action: aSelector nib: aMask evt: evt "Set the current tool and action for the paintBox. " currentBrush ifNotNil: [currentBrush == brushButton ifFalse: [currentBrush state: #off]]. currentBrush := brushButton. "A ThreePhaseButtonMorph" "currentBrush state: #on. already done" "aSelector is like brush3:. Don't save it. Can always say (currentBrush arguments at: 2) aMask is the brush shape. Don't save it. Can always say (currentBrush arguments at: 3)" self notifyWeakDependentsWith: { #currentNib. evt. currentBrush arguments third}. self brushable ifFalse: [self setAction: #paint: evt: evt] "User now thinking of painting"! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! deleteCurrentStamp: evt "The trash is telling us to delete the currently selected stamp" (tool arguments second) == #stamp: ifTrue: [stampHolder remove: tool. self setAction: #paint: evt: evt] "no use stamping with a blank stamp"! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'JMM 9/13/2004 09:47'! eyedropper: aButton action: aSelector cursor: aCursor evt: evt "Take total control and pick up a color!!!!" | pt feedbackColor delay | delay _ Delay forMilliseconds: 10. aButton state: #on. tool ifNotNil: [tool state: #off]. currentCursor := aCursor. evt hand showTemporaryCursor: currentCursor hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" feedbackColor := Display colorAt: Sensor cursorPoint. colorMemory align: colorMemory bounds topRight with: colorMemoryThin bounds topRight. self addMorphFront: colorMemory. "Full color picker" [Sensor anyButtonPressed] whileFalse: [pt := Sensor cursorPoint. "deal with the fact that 32 bit displays may have garbage in the alpha bits" feedbackColor := Display depth = 32 ifTrue: [Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 4278190080) depth: 32] ifFalse: [Display colorAt: pt]. "the hand needs to be drawn" evt hand position: pt. currentColor ~= feedbackColor ifTrue: [ currentColor _ feedbackColor. self showColor ]. self world displayWorldSafely. delay wait]. "Now wait for the button to be released." [Sensor anyButtonPressed] whileTrue: [ pt := Sensor cursorPoint. "the hand needs to be drawn" evt hand position: pt. self world displayWorldSafely. delay wait]. evt hand showTemporaryCursor: nil hotSpotOffset: 0 @ 0. self currentColor: feedbackColor evt: evt. colorMemory delete. tool ifNotNil: [tool state: #on. currentCursor := tool arguments third]. aButton state: #off ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:03'! getNib ^currentBrush arguments third! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/21/2003 23:17'! grabFromScreen: evt "Allow the user to grab a picture from the screen OUTSIDE THE PAINTING AREA and install it in a blank stamp. To get a stamp in the painting area, click on the stamp tool in a blank stamp." "scroll to blank stamp" | stampButton form | stampButton := stampHolder stampButtons first. [(stampHolder stampFormFor: stampButton) isNil] whileFalse: [stampHolder scroll: 1]. form := Form fromUser. tool state: #off. tool := stampHolder otherButtonFor: stampButton. stampHolder stampForm: form for: tool. "install it" stampButton state: #on. stampButton doButtonAction: evt. evt hand showTemporaryCursor: (focusMorph getCursorFor: evt)! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'! pickup: actionButton action: aSelector cursor: aCursor evt: evt "Special version for pickup: and stamp:, because of these tests" | ss picker old map stamper | self tool: actionButton action: aSelector cursor: aCursor evt: evt. aSelector == #stamp: ifTrue: [(stampHolder pickupButtons includes: actionButton) ifTrue: [stamper := stampHolder otherButtonFor: actionButton. ^self pickup: stamper action: #stamp: cursor: (stamper arguments third) evt: evt]. (stampHolder stampFormFor: actionButton) ifNil: ["If not stamp there, go to pickup mode" picker := stampHolder otherButtonFor: actionButton. picker state: #on. ^self pickup: picker action: #pickup: cursor: (picker arguments third) evt: evt] ifNotNil: [old := stampHolder stampFormFor: actionButton. currentCursor := ColorForm extent: old extent depth: 8. old displayOn: currentCursor. map := Color indexedColors copy. map at: 1 put: Color transparent. currentCursor colors: map. currentCursor offset: currentCursor extent // -2. "Emphisize the stamp button" actionButton owner borderColor: (Color r: 0.65 g: 0.599 b: 0.8) "layoutMorph" "color: (Color r: 1.0 g: 0.645 b: 0.419);"]]. aSelector == #pickup: ifTrue: [ss := self focusMorph. ss ifNotNil: [currentCursor := aCursor] ifNil: [self notCurrentlyPainting. self setAction: #paint: evt: evt]]! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'dgd 2/22/2003 19:04'! showColor "Display the current color in all brushes, both on and off." | offIndex onIndex center | currentColor ifNil: [^self]. "colorPatch color: currentColor. May delete later" (brushes isNil or: [brushes first owner ~~ self]) ifTrue: [brushes := OrderedCollection new. #(#brush1: #brush2: #brush3: #brush4: #brush5: #brush6:) do: [:sel | brushes addLast: (self submorphNamed: sel)]]. center := (brushes sixth) offImage extent // 2. offIndex := (brushes sixth) offImage pixelValueAt: center. onIndex := (brushes sixth) onImage pixelValueAt: center. brushes do: [:bb | bb offImage colors at: offIndex + 1 put: currentColor. bb offImage clearColormapCache. bb onImage colors at: onIndex + 1 put: currentColor. bb onImage clearColormapCache. bb invalidRect: bb bounds]. self invalidRect: (brushes first topLeft rect: brushes last bottomRight)! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 12/19/2000 19:16'! showColorPalette: evt | w box | self comeToFront. colorMemory align: colorMemory bounds topRight with: colorMemoryThin bounds topRight. "make sure color memory fits or else align with left" w _ self world. box _ self bounds: colorMemory fullBounds in: w. box left < 0 ifTrue:[ colorMemory align: colorMemory bounds topLeft with: colorMemoryThin bounds topLeft]. self addMorphFront: colorMemory.! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:53'! createButtons "Create buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button nib | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | (self submorphNamed: sel) ifNil: [self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. button actionSelector: #tool:action:cursor:evt:; arguments: (Array with: button with: sel with: nil). button actWhen: #buttonUp; target: self]]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | (self submorphNamed: sel) ifNil: [self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. nib _ Form dotOfSize: (#(1 2 3 6 11 26) at: ind). button actionSelector: #brush:action:nib:evt:; arguments: (Array with: button with: sel with: nib). button actWhen: #buttonUp; target: self]]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:39'! fixupButtons | changes answer newSelector | changes := Dictionary new. changes at: #brush:action:nib: put: #brush:action:nib:evt:; at: #tool:action:cursor: put: #tool:action:cursor:evt:; at: #pickup:action:cursor: put: #pickup:action:cursor:evt:; at: #keep:with: put: #keep:with:evt:; at: #undo:with: put: #undo:with:evt:; at: #scrollStamps:action: put: #scrollStamps:action:evt:; at: #toss:with: put: #toss:with:evt:; at: #eyedropper:action:cursor: put: #eyedropper:action:cursor:evt:; at: #clear:with: put: #clear:with:evt:. answer := WriteStream on: String new. self allMorphsDo: [:each | (each isKindOf: ThreePhaseButtonMorph) ifTrue: [answer nextPutAll: each actionSelector. (changes includesKey: each actionSelector) ifTrue: [each actionSelector: (newSelector := changes at: each actionSelector). answer nextPutAll: ' <-- ' , newSelector]. answer cr]]. ^answer contents "StringHolder new contents: answer contents; openLabel: 'button fixups'"! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'dgd 2/22/2003 19:03'! init3 "Just a record of how we loaded in the latest paintbox button images" | bb rect lay pic16Bit aa blt on thin | self loadoffImage: 'etoy_default.gif'. self allMorphsDo: [:button | (button isKindOf: ThreePhaseButtonMorph) ifTrue: [button offImage: nil] ifFalse: [button position: button position + (100 @ 0)]]. (bb := self submorphNamed: #keep:) position: bb position + (100 @ 0). (bb := self submorphNamed: #toss:) position: bb position + (100 @ 0). (bb := self submorphNamed: #undo:) position: bb position + (100 @ 0). "Transparent is (Color r: 1.0 g: 0 b: 1.0)" self moveButtons. self loadOnImage: 'etoy_in.gif'. AllOnImage := nil. 'save space'. self loadPressedImage: 'etoy_in.gif'. AllPressedImage := nil. 'save space'. self loadCursors. "position the stamp buttons" stampHolder stampButtons owner last delete. stampHolder pickupButtons last delete. stampHolder stampButtons: (stampHolder stampButtons copyFrom: 1 to: 3). stampHolder pickupButtons: (stampHolder pickupButtons copyFrom: 1 to: 3). "| rect |" stampHolder pickupButtons do: [:button | "PopUpMenu notify: 'Rectangle for ',sel." rect := Rectangle fromUser. button bounds: rect "image is nil"]. "| rect lay |" stampHolder clear. stampHolder stampButtons do: [:button | button offImage: nil; pressedImage: nil. lay := button owner. "PopUpMenu notify: 'Rectangle for ',sel." rect := Rectangle fromUser. button image: (Form fromDisplay: (rect insetBy: 2)). lay borderWidth: 2. lay bounds: rect "image is nil"]. "| pic16Bit blt aa on |" pic16Bit := GIFReadWriter formFromFileNamed: 'etoy_in.gif'. "really 8" aa := Form extent: OriginalBounds extent depth: 8. blt := BitBlt current toForm: aa. blt sourceForm: pic16Bit; combinationRule: Form over; sourceRect: OriginalBounds; destOrigin: 0 @ 0; copyBits. "Collect all the images for the buttons in the on state" stampHolder pickupButtons do: [:button | on := ColorForm extent: button extent depth: 8. on colors: pic16Bit colors. on copy: (0 @ 0 extent: button extent) from: button topLeft - self topLeft in: aa rule: Form over. button image: on; pressedImage: on; offImage: nil]. self invalidRect: bounds. ((self submorphNamed: #erase:) arguments third) offset: 12 @ 35. ((self submorphNamed: #eyedropper:) arguments third) offset: 0 @ 0. ((self submorphNamed: #fill:) arguments third) offset: 10 @ 44. ((self submorphNamed: #paint:) arguments third) offset: 3 @ 3. "unused" ((self submorphNamed: #rect:) arguments third) offset: 6 @ 17. ((self submorphNamed: #ellipse:) arguments third) offset: 5 @ 4. ((self submorphNamed: #polygon:) arguments third) offset: 5 @ 4. ((self submorphNamed: #line:) arguments third) offset: 5 @ 17. ((self submorphNamed: #star:) arguments third) offset: 2 @ 5. thumbnail delete. thumbnail := nil. (submorphs select: [:e | e class == RectangleMorph]) first bounds: Rectangle fromUser. ((submorphs select: [:e | e class == RectangleMorph]) first) borderWidth: 1; borderColor: Color black. "| thin |" submorphs do: [:ss | ss class == ImageMorph ifTrue: [thin := ss "first"]]. colorMemoryThin := thin! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! loadCursors "Display the form containing the cursors. Transparent is (Color r: 1.0 g: 0 b: 1.0). Grab the forms one at a time, and they are stored away. self loadCursors. " | button transp cursor map | transp _ Color r: 1.0 g: 0 b: 1.0. map _ Color indexedColors copy. "just in case" 1 to: 256 do: [:ind | (map at: ind) = transp ifTrue: [map at: ind put: Color transparent]]. #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: ) do: [:sel | self inform: 'Rectangle for ',sel. cursor _ ColorForm fromUser. cursor colors: map. "share it" button _ self submorphNamed: sel. button arguments at: 3 put: cursor]. ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 1/13/2005 12:20'! loadJapanesePaintBoxBitmaps " PaintBoxMorph new loadJapanesePaintBoxBitmaps. " | formTranslator form bb | self position: 0@0. formTranslator _ NaturalLanguageFormTranslator localeID: (LocaleID isoString: 'ja'). form _ Form fromFileNamed: 'offPaletteJapanese(children).form'. #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | bb _ (self submorphs detect: [:e | e externalName = extName]) bounds. formTranslator name: label, '-off' form: (form copy: bb) ]. form _ Form fromFileNamed: 'pressedPaletteJapanese(children).form'. #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | bb _ (self submorphs detect: [:e | e externalName = extName]) bounds. formTranslator name: label, '-pressed' form: (form copy: bb) ]. ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'! loadOffForm: pic16Bit "Prototype loadOffForm: (Smalltalk imageImports at: #offPaletteJapanese)" | blt | OriginalBounds _ pic16Bit boundingBox. AllOffImage _ Form extent: OriginalBounds extent depth: 16. blt _ BitBlt current toForm: AllOffImage. blt sourceForm: pic16Bit; combinationRule: Form over; sourceRect: OriginalBounds; destOrigin: 0 @ 0; copyBits. AllOffImage mapColor: Color blue to: Color transparent. self image: AllOffImage. AllOffImage _ nil. self invalidRect: bounds ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'yo 11/4/2002 21:20'! loadPressedForm: pic16Bit "Prototype loadPressedForm: (Smalltalk imageImports at: #pressedPaletteJapanese)" | blt on | AllPressedImage _ AllPressedImage _ Form extent: OriginalBounds extent depth: 16. blt _ BitBlt current toForm: AllPressedImage. blt sourceForm: pic16Bit; combinationRule: Form over; sourceRect: OriginalBounds; destOrigin: 0 @ 0; copyBits. AllPressedImage mapColor: Color black to: Color transparent. self allMorphsDo: [:button | (button isKindOf: ThreePhaseButtonMorph) ifTrue: [on _ Form extent: button extent depth: 16. on copy: (0 @ 0 extent: button extent) from: button topLeft - self topLeft in: AllPressedImage rule: Form over. button pressedImage: on]]. AllPressedImage _ nil. self invalidRect: bounds ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'md 11/14/2003 16:52'! loadoffImage: fileName "Read in and convert the background image for the paintBox. All buttons off. A .bmp 24-bit image." " Prototype loadoffImage: 'roundedPalette3.bmp' " | pic16Bit blt type getBounds | type _ 'bmp'. " gif or bmp " getBounds _ 'fromPic'. "fromUser = draw out rect of paintbox on image" "fromOB = just read in new bits, keep same size and place as last time." "fromPic = picture is just the PaintBox, use its bounds" type = 'gif' ifTrue: [ pic16Bit "really 8" _ GIFReadWriter formFromFileNamed: fileName. getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds" pic16Bit display. OriginalBounds _ Rectangle fromUser]. getBounds = 'fromPic' ifTrue: [OriginalBounds _ pic16Bit boundingBox]. ]. "Use OriginalBounds as it was last time" type = 'bmp' ifTrue: [ pic16Bit _ (Form fromBMPFileNamed: fileName) asFormOfDepth: 16. getBounds = 'fromUser' ifTrue: ["Just first time, collect the bounds" pic16Bit display. OriginalBounds _ Rectangle fromUser]. "Use OriginalBounds as it was last time" (getBounds = 'fromPic') ifTrue: [OriginalBounds _ pic16Bit boundingBox]. AllOffImage _ Form extent: OriginalBounds extent depth: 16. ]. type = 'gif' ifTrue: [ AllOffImage _ ColorForm extent: OriginalBounds extent depth: 8. AllOffImage colors: pic16Bit colors]. blt _ BitBlt current toForm: AllOffImage. blt sourceForm: pic16Bit; combinationRule: Form over; sourceRect: OriginalBounds; destOrigin: 0@0; copyBits. type = 'bmp' ifTrue: [AllOffImage mapColor: Color transparent to: Color black]. self image: AllOffImage. self invalidRect: bounds. ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'sw 5/23/2001 13:54'! moveButtons "Move buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self submorphNamed: sel. button bounds: rect. "image is nil"]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | self inform: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self submorphNamed: sel. button bounds: rect. "image is nil"]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." " " ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'dgd 8/30/2003 21:55'! addCustomMenuItems: aCustomMenu hand: aHandMorph "super addCustomMenuItems: aCustomMenu hand: aHandMorph." "don't want the ones from ImageMorph" aCustomMenu add: 'grab stamp from screen' translated action: #grabFromScreen:. ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'! addGraphicLabels "translate button labels" | formTranslator ext pos newForm | formTranslator _ NaturalLanguageFormTranslator localeID: (Locale current localeID). #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:label | (formTranslator translate: label, '-off') ifNil: [^ false]. (formTranslator translate: label, '-pressed') ifNil: [^ false]. ]. #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | | button | button _ submorphs detect: [:m | m externalName = extName] ifNone: [nil]. button ifNotNil: [ button removeAllMorphs. ext _ button extent. pos _ button position. (newForm _ formTranslator translate: label, '-off') ifNotNil: [ button offImage: newForm. ]. (newForm _ formTranslator translate: label, '-pressed') ifNotNil: [ button pressedImage: newForm. ]. button extent: ext. button position: pos. ]. ]. ^ true. ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 14:08'! addLabels Preferences useFormsInPaintBox ifFalse: [ self addTextualLabels. ] ifTrue: [ self addGraphicLabels ifFalse: [self addTextualLabels]. ]. ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'yo 1/13/2005 11:06'! addTextualLabels "translate button labels" #('keep:' 'undo:' 'clear:' 'toss:') with: #('KEEP' 'UNDO' 'CLEAR' 'TOSS') do: [:extName :label | | button | button _ submorphs detect: [:m | m externalName = extName] ifNone: [nil]. button ifNotNil: [ button removeAllMorphs. button addMorph: (TextMorph new contentsWrapped: (Text string: label translated attributes: { TextAlignment centered. TextEmphasis bold. TextFontReference toFont: (Preferences standardPaintBoxButtonFont)}); bounds: (button bounds translateBy: 0@3); lock)]]! ! !PaintBoxMorph methodsFor: 'recent colors' stamp: 'JMM 9/13/2004 09:26'! fixUpColorPicker | chart picker | chart _ ColorChart ifNil:[Cursor wait showWhile:[ColorChart _ (Color colorPaletteForDepth: 32 extent: (360+10)@(180+10))]]. chart getCanvas frameRectangle: chart boundingBox color: Color black. picker _ Form extent: (chart extent + (14@12)) depth: 32. picker fillWhite. "top" false ifTrue: [picker copy: (0@0 extent: picker width@6) from: (colorMemory image width - picker width)@0 in: colorMemory image rule: Form over. "bottom" picker copy: (0@ (picker height-6) extent: picker width@6) from: (colorMemory image width - picker width)@(colorMemory image height - 7) in: colorMemory image rule: Form over. "left" picker copy: (0@6 corner: 8@(picker height - 6)) from: (colorMemory image boundingBox topLeft + (0@6)) in: colorMemory image rule: Form over. "right" picker copy: (picker width-6@6 corner: picker width@(picker height - 6)) from: (colorMemory image boundingBox topRight - (6@-6)) in: colorMemory image rule: Form over.]. chart displayOn: picker at: 8@6. picker getCanvas frameRectangle: picker boundingBox color: Color black. colorMemory image: picker. ! ! !PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17'! fixUpRecentColors | inner outer border box form newImage canvas morph | self fixUpColorPicker. recentColors := WriteStream on: Array new. form := image. newImage := Form extent: form extent + (0 @ 41) depth: form depth. form displayOn: newImage. newImage copy: (0 @ (form height - 10) extent: form width @ (newImage height - form height + 10)) from: 0 @ (form height - (newImage height - form height + 10)) in: form rule: Form over. canvas := newImage getCanvas. canvas line: 12 @ (form height - 10) to: 92 @ (form height - 10) width: 1 color: Color black. canvas := canvas copyOffset: 12 @ (form height - 9). inner := Color r: 0.677 g: 0.71 b: 0.968. outer := inner darker darker. border := Color r: 0.194 g: 0.258 b: 0.194. 0 to: 1 do: [:y | 0 to: 3 do: [:x | box := (x * 20) @ (y * 20) extent: 20 @ 20. morph := BorderedMorph new bounds: ((box insetBy: 1) translateBy: canvas origin + bounds origin). morph borderWidth: 1; borderColor: border. morph color: Color white. morph on: #mouseDown send: #mouseDownRecent:with: to: self. morph on: #mouseMove send: #mouseStillDownRecent:with: to: self. morph on: #mouseUp send: #mouseUpRecent:with: to: self. self addMorphFront: morph. recentColors nextPut: morph. canvas fillRectangle: box color: Color white. canvas frameRectangle: (box insetBy: 1) color: border. canvas frameRectangle: box color: inner. box := box insetBy: 1. canvas line: box topRight to: box bottomRight width: 1 color: outer. canvas line: box bottomLeft to: box bottomRight width: 1 color: outer]]. recentColors := recentColors contents. (RecentColors isNil or: [RecentColors size ~= recentColors size]) ifTrue: [RecentColors := recentColors collect: [:each | each color]] ifFalse: [RecentColors keysAndValuesDo: [:idx :aColor | (recentColors at: idx) color: aColor]]. self image: newImage. self toggleStamps. self toggleStamps! ! !PaintBoxMorph methodsFor: 'recent colors' stamp: 'dgd 2/21/2003 23:17'! recentColor: aColor "Remember the color as one of our recent colors" (recentColors anySatisfy: [:any | any color = aColor]) ifTrue: [^self]. "already remembered" recentColors size to: 2 by: -1 do: [:i | (recentColors at: i) color: (recentColors at: i - 1) color. RecentColors at: i put: (RecentColors at: i - 1)]. (recentColors first) color: aColor. RecentColors at: 1 put: aColor! ! !PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'JMM 9/13/2004 09:26'! initializeColorChart "PaintBoxMorph initializeColorChart" ColorChart _ (Color colorPaletteForDepth: 32 extent: (360+10)@(180+10))! ! !PaintBoxMorph class methodsFor: 'instance creation' stamp: 'bf 10/11/2004 13:37'! new | pb button dualUse formCanvas rect | pb _ Prototype veryDeepCopy. "Assume that the PaintBox does not contain any scripted Players!!" pb stampHolder normalize. "Get the stamps to show" "Get my own copies of the brushes so I can modify them" #(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel | button _ pb submorphNamed: sel. button offImage: button offImage deepCopy. dualUse _ button onImage == button pressedImage. "sometimes shared" button onImage: button onImage deepCopy. dualUse ifTrue: [button pressedImage: button onImage] ifFalse: [button pressedImage: button pressedImage deepCopy]. "force color maps for later mapping" button offImage. button onImage. button pressedImage. formCanvas _ button onImage getCanvas. formCanvas _ formCanvas copyOrigin: 0@0 clipRect: (rect _ 0@0 extent: button onImage extent). (#(brush1: brush3:) includes: sel) ifTrue: [ rect _ rect origin corner: rect corner - (2@2)]. (#brush2: == sel) ifTrue: [ rect _ rect origin corner: rect corner - (2@4)]. formCanvas frameAndFillRectangle: rect fillColor: Color transparent borderWidth: 2 borderColor: (Color r: 0.599 g: 0.8 b: 1.0). ]. pb showColor. pb fixUpRecentColors. pb addLabels. ^ pb! ! !PaintBoxMorph class methodsFor: 'notification' stamp: 'ka 2/19/2005 01:54'! localeChanged self initializeColorChart! ! !PaintInvokingMorph methodsFor: 'dropping/grabbing' stamp: 'ar 3/3/2001 20:41'! justDroppedInto: aPasteUpMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph" aPasteUpMorph isPartsBin ifFalse:[ self delete. ^aPasteUpMorph makeNewDrawing: anEvent]. ^super justDroppedInto: aPasteUpMorph event: anEvent! ! !PaintInvokingMorph methodsFor: 'dropping/grabbing' stamp: 'ar 3/3/2001 20:40'! wantsToBeDroppedInto: aMorph "Only into PasteUps that are not part bins" ^aMorph isPlayfieldLike! ! !PaintInvokingMorph methodsFor: 'parts bin' stamp: 'sw 8/12/2001 17:19'! initializeToStandAlone super initializeToStandAlone. self image: (ScriptingSystem formAtKey: 'Painting')! ! !PaintInvokingMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:11'! descriptionForPartsBin ^ self partName: 'Paint' categories: #('Basic' 'Graphics') documentation: 'Drop this icon to start painting a new object.'! ! !PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/10/2003 13:16'! initialize self registerInFlapsRegistry.! ! !PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:09'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') forFlapNamed: 'Widgets'. cl registerQuad: #(PaintInvokingMorph new 'Paint' 'Drop this into an area to start making a fresh painting there') forFlapNamed: 'Scripting']! ! !PaintInvokingMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Paragraph methodsFor: 'composition' stamp: 'yo 1/23/2003 22:47'! composeAll "Compose a collection of characters into a collection of lines." | startIndex stopIndex lineIndex maximumRightX compositionScanner | lines _ Array new: 32. lastLine _ 0. maximumRightX _ 0. text size = 0 ifTrue: [compositionRectangle _ compositionRectangle withHeight: 0. ^maximumRightX]. startIndex _ lineIndex _ 1. stopIndex _ text size. compositionScanner _ MultiCompositionScanner new forParagraph: self. [startIndex > stopIndex] whileFalse: [self lineAt: lineIndex put: (compositionScanner composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: self). maximumRightX _ compositionScanner rightX max: maximumRightX. startIndex _ (lines at: lineIndex) last + 1. lineIndex _ lineIndex + 1]. self updateCompositionHeight. self trimLinesTo: lineIndex - 1. ^ maximumRightX! ! !Paragraph methodsFor: 'selecting' stamp: 'dvf 10/1/2003 13:28'! clickAt: clickPoint for: model controller: aController "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | startBlock action range box boxes | action _ false. startBlock _ self characterBlockAtPoint: clickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) do: [:att | att mayActOnClick ifTrue: [range _ text rangeOf: att startingAt: startBlock stringIndex. boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) to: (self characterBlockForIndex: range last+1). box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: [^ action]. Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [aController terminateAndInitializeAround: [(att actOnClickFor: model in: self at: clickPoint editor: aController) ifTrue: [action _ true]]]]]. ^ action! ! !Paragraph methodsFor: 'selecting' stamp: 'th 9/19/2002 17:27'! extendSelectionMark: markBlock pointBlock: pointBlock "Answer with an Array of two CharacterBlocks that represent the text selection that the user makes." true ifTrue:[^self mouseMovedFrom: pointBlock pivotBlock: markBlock showingCaret:(pointBlock = markBlock)] ifFalse: [ | beginBlock endBlock | beginBlock _ markBlock min: pointBlock. endBlock _ markBlock max: endBlock. (self characterBlockAtPoint: Sensor cursorPoint) <= beginBlock ifTrue: [^self mouseMovedFrom: beginBlock pivotBlock: endBlock showingCaret: (beginBlock = endBlock)] ifFalse: [^self mouseMovedFrom: endBlock pivotBlock: beginBlock showingCaret: (beginBlock = endBlock)] ] ! ! !Paragraph methodsFor: 'scrolling' stamp: 'hmm 9/16/2000 21:30'! scrollBy: heightToMove withSelectionFrom: startBlock to: stopBlock "Translate the composition rectangle up (dy<0) by heightToMove. Repainting text as necessary, and selection if blocks not nil. Return true unless scrolling limits have been reached." | max min amount | max _ 0 max: "cant scroll up more than dist to (top of) bottom line" compositionRectangle bottom - textStyle lineGrid - clippingRectangle top. min _ 0 min: "cant scroll down more than top is above clipRect" compositionRectangle top - clippingRectangle top. amount _ ((heightToMove truncateTo: textStyle lineGrid) min: max) max: min. amount ~= 0 ifTrue: [destinationForm deferUpdatesIn: clippingRectangle while: [ self scrollUncheckedBy: amount withSelectionFrom: startBlock to: stopBlock]. ^ true] ifFalse: [^ false]! ! !Paragraph methodsFor: 'converting' stamp: 'yo 6/23/2003 19:05'! asForm "Answer a Form made up of the bits that represent the receiver's displayable text." | theForm oldBackColor oldForeColor | textStyle isTTCStyle ifTrue: [ theForm _ (Form extent: compositionRectangle extent depth: 32) offset: offset. ] ifFalse: [ theForm _ (ColorForm extent: compositionRectangle extent) offset: offset; colors: (Array with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor]) with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])). ]. oldBackColor _ backColor. oldForeColor _ foreColor. backColor _ Color white. foreColor _ Color black. self displayOn: theForm at: 0@0 clippingBox: theForm boundingBox rule: Form over fillColor: nil. backColor _ oldBackColor. foreColor _ oldForeColor. ^ theForm "Example: | p | p _ 'Abc' asParagraph. p foregroundColor: Color red backgroundColor: Color black. p asForm displayOn: Display at: 30@30 rule: Form over" ! ! !Paragraph methodsFor: 'private' stamp: 'yo 1/23/2003 22:48'! displayLines: linesInterval affectedRectangle: affectedRectangle "This is the first level workhorse in the display portion of the TextForm routines. It checks to see which lines in the interval are actually visible, has the CharacterScanner display only those, clears out the areas in which display will occur, and clears any space remaining in the visibleRectangle following the space occupied by lastLine." | lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom | "Save some time by only displaying visible lines" firstLineIndex _ self lineIndexOfTop: affectedRectangle top. firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first]. lastLineIndex _ self lineIndexOfTop: affectedRectangle bottom - 1. lastLineIndex > linesInterval last ifTrue: [linesInterval last > lastLine ifTrue: [lastLineIndex _ lastLine] ifFalse: [lastLineIndex _ linesInterval last]]. lastLineIndexBottom _ (self bottomAtLineIndex: lastLineIndex). ((Rectangle origin: affectedRectangle left @ (topY _ self topAtLineIndex: firstLineIndex) corner: affectedRectangle right @ lastLineIndexBottom) intersects: affectedRectangle) ifTrue: [ " . . . (skip to clear-below if no lines displayed)" MultiDisplayScanner new displayLines: (firstLineIndex to: lastLineIndex) in: self clippedBy: affectedRectangle]. lastLineIndex = lastLine ifTrue: [destinationForm "Clear out white space below last line" fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top) corner: affectedRectangle bottomRight) rule: rule fillColor: self backgroundColor]! ! !Paragraph methodsFor: 'private' stamp: 'ar 12/15/2001 23:29'! leftMarginForDisplayForLine: lineIndex alignment: alignment "Build the left margin for display of a line. Depends upon leftMarginForComposition, compositionRectangle left and the alignment." | pad | (alignment = LeftFlush or: [alignment = Justified]) ifTrue: [^compositionRectangle left + (self leftMarginForCompositionForLine: lineIndex)]. "When called from character location code and entire string has been cut, there are no valid lines, hence following nil check." (lineIndex <= lines size and: [(lines at: lineIndex) notNil]) ifTrue: [pad _ (lines at: lineIndex) paddingWidth] ifFalse: [pad _ compositionRectangle width - textStyle firstIndent - textStyle rightIndent]. alignment = Centered ifTrue: [^compositionRectangle left + (self leftMarginForCompositionForLine: lineIndex) + (pad // 2)]. alignment = RightFlush ifTrue: [^compositionRectangle left + (self leftMarginForCompositionForLine: lineIndex) + pad]. self error: ['no such alignment']! ! !Paragraph commentStamp: '<historical>' prior: 0! I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.! !ParagraphEditor methodsFor: 'initialize-release' stamp: 'th 10/21/2003 15:49'! resetState "Establish the initial conditions for editing the paragraph: place caret before first character, set the emphasis to that of the first character, and save the paragraph for purposes of canceling." stopBlock _ paragraph defaultCharacterBlock. self pointBlock: stopBlock copy. beginTypeInBlock _ nil. UndoInterval _ otherInterval _ 1 to: 0. self setEmphasisHere. selectionShowing _ false. initialText _ paragraph text copy! ! !ParagraphEditor methodsFor: 'scrolling' stamp: 'BG 12/12/2003 15:31'! scrollBy: heightToMove "Move the paragraph by heightToMove, and reset the text selection." ^ paragraph scrollBy: heightToMove withSelectionFrom: self pointBlock to: self markBlock! ! !ParagraphEditor methodsFor: 'sensor access' stamp: 'th 9/19/2002 18:24'! processRedButton "The user pressed a red mouse button, meaning create a new text selection. Highlighting the selection is carried out by the paragraph itself. Double clicking causes a selection of the area between the nearest enclosing delimitors." | selectionBlocks clickPoint oldDelta oldInterval previousMarkBlock previousPointBlock | clickPoint _ sensor cursorPoint. (view containsPoint: clickPoint) ifFalse: [^ self]. (paragraph clickAt: clickPoint for: model controller: self) ifTrue: [^ self]. oldInterval _ self selectionInterval. previousMarkBlock _ self markBlock. previousPointBlock _ self pointBlock. oldDelta _ paragraph scrollDelta. sensor leftShiftDown ifFalse: [self deselect. self closeTypeIn. selectionBlocks _ paragraph mouseSelect: clickPoint] ifTrue: [selectionBlocks _ paragraph extendSelectionMark: self markBlock pointBlock: self pointBlock. self closeTypeIn]. selectionShowing _ true. self markBlock: (selectionBlocks at: 1). self pointBlock: (selectionBlocks at: 2). (self hasCaret and: [previousMarkBlock = self markBlock and: [previousPointBlock = self pointBlock]]) ifTrue: [self selectWord]. oldDelta ~= paragraph scrollDelta "case of autoscroll" ifTrue: [self updateMarker]. self setEmphasisHere. (self isDisjointFrom: oldInterval) ifTrue: [otherInterval _ oldInterval]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/24/2001 12:22'! browseChangeSetsWithSelector "Determine which, if any, change sets have at least one change for the selected selector, independent of class" | aSelector | self lineSelectAndEmptyCheck: [^ self]. (aSelector _ self selectedSelector) == nil ifTrue: [^ view flash]. self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 1/16/2004 21:14'! browseClassFromIt "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." | aClass | self lineSelectAndEmptyCheck: [^ self]. aClass _ Utilities classFromPattern: (self selection string copyWithout: Character cr) withCaption: 'choose a class to browse...'. aClass ifNil: [^ view flash]. self terminateAndInitializeAround: [self systemNavigation spawnHierarchyForClass: aClass selector: nil]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'md\ 9/17/2004 14:40'! browseIt "Launch a browser for the current selection, if appropriate" | aSymbol anEntry brow | self flag: #yoCharCases. Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. self lineSelectAndEmptyCheck: [^ self]. (aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash]. self terminateAndInitializeAround: [aSymbol first isUppercase ifTrue: [anEntry _ (Smalltalk at: aSymbol ifAbsent: [ self systemNavigation browseAllImplementorsOf: aSymbol. ^ nil]). anEntry isNil ifTrue: [^ view flash]. (anEntry isKindOf: Class) ifFalse: [anEntry _ anEntry class]. brow _ SystemBrowser default new. brow setClass: anEntry selector: nil. brow class openBrowserView: (brow openEditString: nil) label: 'System Browser'] ifFalse: [ self systemNavigation browseAllImplementorsOf: aSymbol]]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 2/17/2005 17:53'! changeAlignment | aList reply | aList _ #(leftFlush centered justified rightFlush). reply _ (SelectionMenu labelList: (aList collect: [:t | t translated]) selections: aList) startUp. reply ifNil:[^self]. self setAlignment: reply. paragraph composeAll. self recomputeSelection. self mvcRedisplay. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 3/14/2005 13:03'! changeEmphasis | aList reply | aList _ #(normal bold italic narrow underlined struckOut). reply _ (SelectionMenu labelList: (aList collect: [:t | t translated]) selections: aList) startUp. reply ~~ nil ifTrue: [self setEmphasis: reply. paragraph composeAll. self recomputeSelection. self mvcRedisplay]. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'fc 2/19/2004 22:09'! changeEmphasisOrAlignment | aList reply | aList _ #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified). reply _ (SelectionMenu labelList: aList lines: #(6) selections: aList) startUp. reply ~~ nil ifTrue: [(#(leftFlush centered rightFlush justified) includes: reply) ifTrue: [paragraph perform: reply. self recomputeInterval] ifFalse: [self setEmphasis: reply. paragraph composeAll. self recomputeSelection. self mvcRedisplay]]. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'md 10/22/2003 15:27'! changeStyle "Let user change styles for the current text pane Moved from experimentalCommand to its own method " | aList reply style | aList _ StrikeFont actualFamilyNames. aList addFirst: 'DefaultTextStyle'. reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp. reply ifNotNil: [(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true]. paragraph textStyle: style copy. paragraph composeAll. self recomputeSelection. self mvcRedisplay]. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'RAA 3/15/2001 12:10'! changeStyleTo: aNewStyle paragraph textStyle: aNewStyle. paragraph composeAll. self recomputeSelection. ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/15/2003 22:40'! classCommentsContainingIt "Open a browser class comments which contain the current selection somewhere in them." self lineSelectAndEmptyCheck: [^ self]. self terminateAndInitializeAround: [ self systemNavigation browseClassCommentsWithString: self selection string]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'dvf 8/23/2003 11:51'! classNamesContainingIt "Open a browser on classes whose names contain the selected string" self lineSelectAndEmptyCheck: [^self]. self systemNavigation browseClassesWithNamesContaining: self selection string caseSensitive: Sensor leftShiftDown! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 09:42'! implementorsOfIt "Open an implementors browser on the selected selector" | aSelector | self lineSelectAndEmptyCheck: [^ self]. (aSelector _ self selectedSelector) == nil ifTrue: [^ view flash]. self terminateAndInitializeAround: [ self systemNavigation browseAllImplementorsOf: aSelector]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:12'! lineSelectAndEmptyCheck: returnBlock "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this." self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding" self hasSelection ifFalse: [self flash. ^ returnBlock value]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:31'! methodNamesContainingIt "Open a browser on methods names containing the selected string" self lineSelectAndEmptyCheck: [^ self]. Cursor wait showWhile: [self terminateAndInitializeAround: [self systemNavigation browseMethodsWhoseNamesContain: self selection string withBlanksTrimmed]]. Cursor normal show! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/15/2003 22:35'! methodSourceContainingIt "Open a browser on methods which contain the current selection in their source (case-sensitive full-text search of source). EXTREMELY slow!!" self lineSelectAndEmptyCheck: [^ self]. (self confirm: 'This will take a few minutes. Shall I proceed?') ifFalse: [^ self]. self systemNavigation browseMethodsWithSourceString: self selection string! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:28'! methodStringsContainingit "Open a browser on methods which contain the current selection as part of a string constant." self lineSelectAndEmptyCheck: [^ self]. self terminateAndInitializeAround: [self systemNavigation browseMethodsWithString: self selection string]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/20/2002 11:21'! paste "Paste the text from the shared buffer over the current selection and redisplay if necessary. Undoer & Redoer: undoAndReselect." self replace: self selectionInterval with: self clipboardText and: [self selectAt: self pointIndex]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 1/19/2004 20:59'! presentSpecialMenu "Present a list of expressions, and if the user chooses one, evaluate it in the context of the receiver, a ParagraphEditor. Primarily for debugging, this provides a convenient way to talk to the various views, controllers, and models associated with any text pane" | reply items | self terminateAndInitializeAround: [reply _ (PopUpMenu labelArray: (items _ self specialMenuItems) lines: #()) startUp. reply = 0 ifTrue: [^ self]. Compiler new evaluate: (items at: reply) in: [] to: self] ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 11:47'! referencesToIt "Open a references browser on the selected symbol" | aSymbol | self selectLine. ((aSymbol _ self selectedSymbol) == nil or: [(Smalltalk includesKey: aSymbol) not]) ifTrue: [^ view flash]. self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 3/12/2002 20:59'! saveContentsInFile "Save the receiver's contents string to a file, prompting the user for a file-name. Suggest a reasonable file-name." | fileName stringToSave parentWindow labelToUse suggestedName lastIndex | stringToSave _ paragraph text string. stringToSave size == 0 ifTrue: [^ self inform: 'nothing to save.']. parentWindow _ self model dependents detect: [:dep | dep isKindOf: SystemWindow orOf: StandardSystemView] ifNone: [nil]. labelToUse _ parentWindow ifNil: ['Untitled'] ifNotNil: [parentWindow label]. suggestedName _ nil. #(('Decompressed contents of: ' '.gz')) do: "can add more here..." [:leaderTrailer | (labelToUse beginsWith: leaderTrailer first) ifTrue: [suggestedName _ labelToUse copyFrom: leaderTrailer first size + 1 to: labelToUse size. (labelToUse endsWith: leaderTrailer last) ifTrue: [suggestedName _ suggestedName copyFrom: 1 to: suggestedName size - leaderTrailer last size] ifFalse: [lastIndex _ suggestedName lastIndexOf: $. ifAbsent: [0]. (lastIndex = 0 or: [lastIndex = 1]) ifFalse: [suggestedName _ suggestedName copyFrom: 1 to: lastIndex - 1]]]]. suggestedName ifNil: [suggestedName _ labelToUse, '.text']. fileName _ FillInTheBlank request: 'File name?' initialAnswer: suggestedName. fileName isEmptyOrNil ifFalse: [(FileStream newFileNamed: fileName) nextPutAll: stringToSave; close]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'yo 7/5/2004 16:38'! selectedSymbol "Return the currently selected symbol, or nil if none. Spaces, tabs and returns are ignored" | aString | self hasCaret ifTrue: [^ nil]. aString _ self selection string. aString isOctetString ifTrue: [aString _ aString asOctetString]. aString _ aString copyWithoutAll: {Character space. Character cr. Character tab}. aString size == 0 ifTrue: [^ nil]. Symbol hasInterned: aString ifTrue: [:sym | ^ sym]. ^ nil! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 2/23/2001 09:26'! selectionAsTiles "Try to make new universal tiles from the selected text" | selection tiles | selection _ self selection. self terminateAndInitializeAround: [self currentHand attachMorph: (tiles _ Player tilesFrom: selection). Preferences tileTranslucentDrag ifTrue: [tiles lookTranslucent] ifFalse: [tiles align: tiles topLeft with: self currentHand position + tiles cursorBaseOffset]].! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'gm 2/16/2003 20:38'! sendContentsToPrinter | textToPrint printer parentWindow | textToPrint := paragraph text. textToPrint size == 0 ifTrue: [^self inform: 'nothing to print.']. printer := TextPrinter defaultTextPrinter. parentWindow := self model dependents detect: [:dep | dep isSystemWindow] ifNone: [nil]. parentWindow isNil ifTrue: [printer documentTitle: 'Untitled'] ifFalse: [printer documentTitle: parentWindow label]. printer printText: textToPrint! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sd 4/16/2003 19:30'! sendersOfIt "Open a senders browser on the selected selector" | aSelector | self lineSelectAndEmptyCheck: [^ self]. (aSelector _ self selectedSelector) == nil ifTrue: [^ view flash]. self terminateAndInitializeAround: [self systemNavigation browseAllCallsOn: aSelector]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/18/2002 17:28'! setAlignment: aSymbol | attr interval | attr _ TextAlignment perform: aSymbol. interval _ self encompassLine: self selectionInterval. paragraph replaceFrom: interval first to: interval last with: ((paragraph text copyFrom: interval first to: interval last) addAttribute: attr) displaying: true. ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'th 9/19/2002 18:27'! setSearchString "Make the current selection, if any, be the current search string." self hasCaret ifTrue: [view flash. ^ self]. self setSearch: self selection string! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'dgd 8/28/2004 13:59'! spawn "Create and schedule a message browser for the code of the model's selected message. Retain any edits that have not yet been accepted." | code | code _ paragraph text string. self cancel. model notNil ifTrue:[model spawn: code]. ! ! !ParagraphEditor methodsFor: 'explain' stamp: 'nk 6/26/2003 22:02'! explainAnySel: symbol "Is this any message selector?" | list reply | list _ self systemNavigation allClassesImplementing: symbol. list size = 0 ifTrue: [^nil]. list size < 12 ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString] ifFalse: [reply _ ' is a message selector which is defined in many classes']. ^'"' , symbol , reply , '."' , '\' withCRs, 'SystemNavigation new browseAllImplementorsOf: #' , symbol! ! !ParagraphEditor methodsFor: 'explain' stamp: 'di 1/30/2002 21:09'! explainChar: string "Does string start with a special character?" | char | char _ string at: 1. char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement. A period in the middle of a number means a decimal point. (The number is an instance of class Float)."']. char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"']. char = $" ifTrue: [^'"Double quotes enclose a comment. Smalltalk ignores everything between double quotes."']. char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol. If parenthesis follow a hash mark, an instance of class Array is made. It contains literal constants."']. (char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"']. (char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code. It becomes an instance of BlockContext and is usually passed as an argument."']. (char = ${ or: [char = $}]) ifTrue: [^ '"A sequence of expressions separated by periods, when enclosed in curly braces, are evaluated to yield the elements of a new Array"']. (char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine. If this method is primitive, its Smalltalk code is executed only when the primitive fails."']. char = $^ ifTrue: [^'"Uparrow means return from this method. The value returned is the expression following the ^"']. char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method. In a block, the vertical bar separates the argument names from the rest of the code."']. char = $_ ifTrue: [^'"Left arrow means assignment. The value of the expression after the left arrow is stored into the variable before it."']. char = $; ifTrue: [^'"Semicolon means cascading. The message after the semicolon is sent to the same object which received the message before the semicolon."']. char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow. Methods which take more than one argument have selectors with more than one keyword. (One keyword, ending with a colon, appears before each argument).', '\\' withCRs, 'A colon before a variable name just inside a block means that the block takes an agrument. (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."']. char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"']. char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."']. char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."']. char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix. The digits before the r denote the base and the digits after it express a number in that base."']. char = Character space ifTrue: [^'"the space Character"']. char = Character tab ifTrue: [^'"the tab Character"']. char = Character cr ifTrue: [^'"the carriage return Character"']. ^nil! ! !ParagraphEditor methodsFor: 'explain' stamp: 'nk 6/10/2004 07:02'! explainClass: symbol "Is symbol a class variable or a pool variable?" | class reply classes | (model respondsTo: #selectedClassOrMetaClass) ifFalse: [^ nil]. (class _ model selectedClassOrMetaClass) ifNil: [^ nil]. "no class is selected" (class isKindOf: Metaclass) ifTrue: [class _ class soleInstance]. classes _ (Array with: class) , class allSuperclasses. "class variables" reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] ifNone: []) ~~ nil] ifNone: []. reply == nil ifFalse: [^ '"is a class variable, defined in class ' , reply printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , reply printString , ' classPool associationAt: #' , symbol , ').']. "pool variables" classes do: [:each | (each sharedPools detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]] ifNone: []) ~~ nil]. reply ifNil: [(Undeclared includesKey: symbol) ifTrue: [^ '"is an undeclared variable.' , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (Undeclared associationAt: #' , symbol , ').']] ifNotNil: [classes _ WriteStream on: Array new. self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes nextPut: each]]. "Perhaps not print whole list of classes if too long. (unlikely)" ^ '"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply) asString , ', which is used by the following classes ' , classes contents printString , '"\' withCRs , 'SystemNavigation new browseAllCallsOn: (' , (Smalltalk keyAtIdentityValue: reply) asString , ' bindingOf: #' , symbol , ').']. ^ nil! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/29/2003 20:07'! explainGlobal: symbol "Is symbol a global variable?" | reply classes | reply _ Smalltalk at: symbol ifAbsent: [^nil]. (reply class == Dictionary or:[reply isKindOf: SharedPool class]) ifTrue: [classes _ Set new. self systemNavigation allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes add: each]]. classes _ classes printString. ^'"is a global variable. It is a pool which is used by the following classes ' , (classes allButFirst: 5) , '"']. (reply isKindOf: Behavior) ifTrue: [^'"is a global variable. ' , symbol , ' is a class in category ', reply category, '."', '\' withCRs, 'Browser newOnClass: ' , symbol , '.']. symbol == #Smalltalk ifTrue: [^'"is a global. Smalltalk is the only instance of SystemDictionary and holds all global variables."']. ^'"is a global variable. ' , symbol , ' is ' , reply printString , '"'! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tpr 5/12/2004 16:22'! explainInst: string "Is string an instance variable of this class?" | classes cls | (model respondsTo: #selectedClassOrMetaClass) ifTrue: [ cls _ model selectedClassOrMetaClass]. cls ifNil: [^ nil]. "no class known" classes _ (Array with: cls) , cls allSuperclasses. classes _ classes detect: [:each | (each instVarNames detect: [:name | name = string] ifNone: []) ~~ nil] ifNone: [^nil]. classes _ classes printString. ^ '"is an instance variable of the receiver; defined in class ' , classes , '"\' withCRs , classes , ' systemNavigation browseAllAccessesTo: ''' , string , ''' from: ', classes, '.'! ! !ParagraphEditor methodsFor: 'explain' stamp: 'nb 5/6/2003 16:54'! explainMySel: symbol "Is symbol the selector of this method? Is it sent by this method? If not, then expalin will call (explainPartSel:) to see if it is a fragment of a selector sent here. If not, explain will call (explainAnySel:) to catch any selector. " | lits classes msg | (model respondsTo: #selectedMessageName) ifFalse: [^ nil]. (msg _ model selectedMessageName) ifNil: [^nil]. "not in a message" classes _ self systemNavigation allClassesImplementing: symbol. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. msg = symbol ifTrue: [^ '"' , symbol , ' is the selector of this very method!! It is defined in ', classes , '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'] ifFalse: [lits _ (model selectedClassOrMetaClass compiledMethodAt: msg) messages. (lits detect: [:each | each == symbol] ifNone: []) == nil ifTrue: [^nil]. ^ '"' , symbol , ' is a message selector which is defined in ', classes , '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].! ! !ParagraphEditor methodsFor: 'explain' stamp: 'nb 5/6/2003 16:54'! explainPartSel: string "Is this a fragment of a multiple-argument selector sent in this method?" | lits whole reply classes s msg | (model respondsTo: #selectedMessageName) ifFalse: [^ nil]. (msg _ model selectedMessageName) ifNil: [^ nil]. "not in a message" string last == $: ifFalse: [^ nil]. "Name of this method" lits _ Array with: msg. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ ', which is the selector of this very method!!'. s _ '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'] ifFalse: ["Selectors called from this method" lits _ (model selectedClassOrMetaClass compiledMethodAt: msg) messages. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifFalse: [string = 'primitive:' ifTrue: [^self explainChar: '<'] ifFalse: [^nil]]. reply _ '.'. s _ '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']. classes _ self systemNavigation allClassesImplementing: whole. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. ^ '"' , string , ' is one part of the message selector ' , whole, reply , ' It is defined in ' , classes , s! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'hpt 8/5/2004 20:21'! browseIt: characterStream "Triggered by Cmd-B; browse the thing represented by the current selection, if plausible. 1/18/96 sw" sensor keyboard. "flush character" self browseIt. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'tween 8/28/2004 14:02'! changeEmphasis: characterStream "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change. Keeps typeahead." | keyCode attribute oldAttributes index thisSel colors extras indexOfOldAttributes | "control 0..9 -> 0..9" keyCode := ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1. "grab the old set of attributes" indexOfOldAttributes := startBlock stringIndex = stopBlock stringIndex ifTrue:[ "selection is empty, look on character to the left" (startBlock stringIndex - 1) max: 1] ifFalse:[ "selection is not empty, look on leftmost character in the selection" startBlock stringIndex min: stopBlock stringIndex]. oldAttributes := paragraph text attributesAt: indexOfOldAttributes forStyle: paragraph textStyle. thisSel := self selection. "Decipher keyCodes for Command 0-9..." (keyCode between: 1 and: 5) ifTrue: [attribute := TextFontChange fontNumber: keyCode]. keyCode = 6 ifTrue: [colors := #(black magenta red yellow green blue cyan white). extras := ((self class name = #TextMorphEditor) and: [(self morph isKindOf: TextMorphForEditView) not]) "not a system window" ifTrue: [#()] ifFalse: [#('Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method')]. index := (PopUpMenu labelArray: colors , #('choose color...' 'Do it' 'Print it'), extras, #('be a web URL link' 'Edit hidden info' 'Copy hidden info') lines: (Array with: colors size +1)) startUp. index = 0 ifTrue: [^ true]. index <= colors size ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))] ifFalse: [index := index - colors size - 1. "Re-number!!!!!!" index = 0 ifTrue: [attribute := self chooseColor]. index = 1 ifTrue: [attribute := TextDoIt new. thisSel := attribute analyze: self selection asString]. index = 2 ifTrue: [attribute := TextPrintIt new. thisSel := attribute analyze: self selection asString]. (extras size = 0) & (index > 2) ifTrue: [index := index + 4]. "skip those" index = 3 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Comment']. index = 4 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Definition']. index = 5 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString with: 'Hierarchy']. index = 6 ifTrue: [attribute := TextLink new. thisSel := attribute analyze: self selection asString]. index = 7 ifTrue: [attribute := TextURL new. thisSel := attribute analyze: self selection asString]. index = 8 ifTrue: ["Edit hidden info" thisSel := self hiddenInfo. "includes selection" attribute := TextEmphasis normal]. index = 9 ifTrue: ["Copy hidden info" self copyHiddenInfo. ^ true]. "no other action" thisSel ifNil: [^ true]]. "Could not figure out what to link to" ]. (keyCode between: 7 and: 11) ifTrue: [sensor leftShiftDown ifTrue: [keyCode = 10 ifTrue: [attribute := TextKern kern: -1]. keyCode = 11 ifTrue: [attribute := TextKern kern: 1]] ifFalse: [attribute := TextEmphasis perform: (#(bold italic narrow underlined struckOut) at: keyCode - 6). oldAttributes do: [:att | ((att dominates: attribute) and: [att ~= TextEmphasis normal]) ifTrue: [attribute turnOff]]]]. (keyCode = 0) ifTrue: [attribute := TextEmphasis normal]. beginTypeInBlock ~~ nil ifTrue: [self insertTypeAhead: characterStream] ifFalse: [self replaceSelectionWith: (thisSel asText addAttribute: attribute)]. emphasisHere := Text addAttribute: attribute toArray: oldAttributes. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 09:11'! chooseColor "Make a new Text Color Attribute, let the user pick a color, and return the attribute. This is the non-Morphic version." ^ TextColor color: (Color fromUser)! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'tk 5/7/2001 08:47'! copyHiddenInfo "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Copy that to the clipboard. You can paste it and see what it is. Usually enclosed in <>." ^ self clipboardTextPut: self hiddenInfo asText! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/20/2002 11:41'! duplicate: characterStream "Paste the current selection over the prior selection, if it is non-overlapping and legal. Flushes typeahead. Undoer & Redoer: undoAndReselect." sensor keyboard. self closeTypeIn. (self hasSelection and: [self isDisjointFrom: otherInterval]) ifTrue: "Something to duplicate" [self replace: otherInterval with: self selection and: [self selectAt: self pointIndex]] ifFalse: [view flash]. ^true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:01'! enclose: characterStream "Insert or remove bracket characters around the current selection. Flushes typeahead." | char left right startIndex stopIndex oldSelection which text | char _ sensor keyboard. self closeTypeIn. startIndex _ self startIndex. stopIndex _ self stopIndex. oldSelection _ self selection. which _ '([<{"''' indexOf: char ifAbsent: [ ^true ]. left _ '([<{"''' at: which. right _ ')]>}"''' at: which. text _ paragraph text. ((startIndex > 1 and: [stopIndex <= text size]) and: [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]]) ifTrue: ["already enclosed; strip off brackets" self selectFrom: startIndex-1 to: stopIndex. self replaceSelectionWith: oldSelection] ifFalse: ["not enclosed; enclose by matching brackets" self replaceSelectionWith: (Text string: (String with: left), oldSelection string ,(String with: right) emphasis: emphasisHere). self selectFrom: startIndex+1 to: stopIndex]. ^true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 4/24/2001 12:28'! fileItIn: characterStream "File in the selection; invoked via a keyboard shortcut, -- for now, cmd-shift-G." sensor keyboard. "flush character" self terminateAndInitializeAround: [self fileItIn]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:31'! hiddenInfo "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Return the entire string that was used by Cmd-6 to create this text attribute. Usually enclosed in < >." | attrList | attrList _ paragraph text attributesAt: (self pointIndex + self markIndex)//2 forStyle: paragraph textStyle. attrList do: [:attr | (attr isKindOf: TextAction) ifTrue: [^ self selection asString, '<', attr info, '>']]. "If none of the above" attrList do: [:attr | attr class == TextColor ifTrue: [^ self selection asString, '<', attr color printString, '>']]. ^ self selection asString, '[No hidden info]'! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:28'! inOutdent: characterStream delta: delta "Add/remove a tab at the front of every line occupied by the selection. Flushes typeahead. Derived from work by Larry Tesler back in December 1985. Now triggered by Cmd-L and Cmd-R. 2/29/96 sw" | cr realStart realStop lines startLine stopLine start stop adjustStart indentation size numLines inStream newString outStream | sensor keyboard. "Flush typeahead" cr _ Character cr. "Operate on entire lines, but remember the real selection for re-highlighting later" realStart _ self startIndex. realStop _ self stopIndex - 1. "Special case a caret on a line of its own, including weird case at end of paragraph" (realStart > realStop and: [realStart < 2 or: [(paragraph string at: realStart - 1) == cr]]) ifTrue: [delta < 0 ifTrue: [view flash] ifFalse: [self replaceSelectionWith: Character tab asSymbol asText. self selectAt: realStart + 1]. ^true]. lines _ paragraph lines. startLine _ paragraph lineIndexOfCharacterIndex: realStart. stopLine _ paragraph lineIndexOfCharacterIndex: (realStart max: realStop). start _ (lines at: startLine) first. stop _ (lines at: stopLine) last. "Pin the start of highlighting unless the selection starts a line" adjustStart _ realStart > start. "Find the indentation of the least-indented non-blank line; never outdent more" indentation _ (startLine to: stopLine) inject: 1000 into: [:m :l | m _ m min: (paragraph indentationOfLineIndex: l ifBlank: [:tabs | 1000])]. size _ stop + 1 - start. numLines _ stopLine + 1 - startLine. inStream _ ReadStream on: paragraph string from: start to: stop. newString _ String new: size + ((numLines * delta) max: 0). outStream _ ReadWriteStream on: newString. "This subroutine does the actual work" self indent: delta fromStream: inStream toStream: outStream. "Adjust the range that will be highlighted later" adjustStart ifTrue: [realStart _ (realStart + delta) max: start]. realStop _ realStop + outStream position - size. "Prepare for another iteration" indentation _ indentation + delta. size _ outStream position. inStream _ outStream setFrom: 1 to: size. outStream == nil ifTrue: "tried to outdent but some line(s) were already left flush" [view flash] ifFalse: [self selectInvisiblyFrom: start to: stop. size = newString size ifFalse: [newString _ outStream contents]. self replaceSelectionWith: newString asText]. self selectFrom: realStart to: realStop. "highlight only the original range" ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:21'! makeProjectLink: characterStream "" | attribute oldAttributes thisSel | sensor keyboard. oldAttributes _ paragraph text attributesAt: self pointIndex forStyle: paragraph textStyle. thisSel _ self selection. attribute _ TextSqkProjectLink new. thisSel _ attribute analyze: self selection asString. thisSel ifNil: [^ true]. beginTypeInBlock ~~ nil ifTrue: "only change emphasisHere while typing" [self insertTypeAhead: characterStream. emphasisHere _ Text addAttribute: attribute toArray: oldAttributes. ^ true]. self replaceSelectionWith: (thisSel asText addAttribute: attribute). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'ls 11/10/2002 12:11'! makeUppercase: characterStream "Force the current selection to uppercase. Triggered by Cmd-Y." sensor keyboard. "flush the triggering cmd-key character" self replaceSelectionWith: (Text fromString: (self selection string asUppercase)). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:48'! pasteInitials: characterStream "Replace the current text selection by an authorship name/date stamp; invoked by cmd-shift-v, easy way to put an authorship stamp in the comments of an editor. Keeps typeahead." sensor keyboard. "flush character" self closeTypeIn: characterStream. self replace: self selectionInterval with: (Text fromString: Utilities changeStamp) and: [self selectAt: self stopIndex]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'yo 5/27/2004 13:56'! setEmphasis: emphasisSymbol "Change the emphasis of the current selection." | oldAttributes attribute | oldAttributes _ paragraph text attributesAt: self selectionInterval first forStyle: paragraph textStyle. attribute _ TextEmphasis perform: emphasisSymbol. (emphasisSymbol == #normal) ifFalse: [oldAttributes do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]. self replaceSelectionWith: (self selection addAttribute: attribute)! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/18/2002 16:20'! shiftEnclose: characterStream "Insert or remove bracket characters around the current selection. Flushes typeahead." | char left right startIndex stopIndex oldSelection which text | char _ sensor keyboard. char = $9 ifTrue: [ char _ $( ]. char = $, ifTrue: [ char _ $< ]. char = $[ ifTrue: [ char _ ${ ]. char = $' ifTrue: [ char _ $" ]. char asciiValue = 27 ifTrue: [ char _ ${ ]. "ctrl-[" self closeTypeIn. startIndex _ self startIndex. stopIndex _ self stopIndex. oldSelection _ self selection. which _ '([<{"''' indexOf: char ifAbsent: [1]. left _ '([<{"''' at: which. right _ ')]>}"''' at: which. text _ paragraph text. ((startIndex > 1 and: [stopIndex <= text size]) and: [(text at: startIndex-1) = left and: [(text at: stopIndex) = right]]) ifTrue: ["already enclosed; strip off brackets" self selectFrom: startIndex-1 to: stopIndex. self replaceSelectionWith: oldSelection] ifFalse: ["not enclosed; enclose by matching brackets" self replaceSelectionWith: (Text string: (String with: left), oldSelection string ,(String with: right) emphasis: emphasisHere). self selectFrom: startIndex+1 to: stopIndex]. ^true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'th 9/19/2002 18:00'! swapChars: characterStream "Triggered byCmd-Y;. Swap two characters, either those straddling the insertion point, or the two that comprise the selection. Suggested by Ted Kaehler. " | currentSelection aString chars | sensor keyboard. "flush the triggering cmd-key character" (chars _ self selection) size == 0 ifTrue: [currentSelection _ self pointIndex. self selectMark: currentSelection - 1 point: currentSelection] ifFalse: [chars size == 2 ifFalse: [view flash. ^ true] ifTrue: [currentSelection _ self pointIndex - 1]]. aString _ self selection string. self replaceSelectionWith: (Text string: aString reversed emphasis: emphasisHere). self selectAt: currentSelection + 1. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:08'! cursorDown: characterStream "Private - Move cursor from position in current line to same position in next line. If next line too short, put at end. If shift key down, select." self closeTypeIn: characterStream. self moveCursor:[:position | self sameColumn: position newLine:[:line | line + 1] forward: true] forward: true specialBlock:[:dummy | dummy]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 10/28/2003 10:47'! cursorEnd: characterStream "Private - Move cursor end of current line." | string | self closeTypeIn: characterStream. string _ paragraph text string. self moveCursor: [:position | Preferences wordStyleCursorMovement ifTrue:[| targetLine | targetLine _ paragraph lines at:(paragraph lineIndexOfCharacterIndex: position). targetLine = paragraph lines last ifTrue:[targetLine last + 1] ifFalse:[targetLine last]] ifFalse:[ string indexOf: Character cr startingAt: position ifAbsent:[string size + 1]]] forward: true specialBlock:[:dummy | string size + 1]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/20/2002 12:14'! cursorHome: characterStream "Private - Move cursor from position in current line to beginning of current line. If control key is pressed put cursor at beginning of text" | string | string _ paragraph text string. self moveCursor: [ :position | Preferences wordStyleCursorMovement ifTrue:[ (paragraph lines at:(paragraph lineIndexOfCharacterIndex: position)) first] ifFalse:[ (string lastIndexOf: Character cr startingAt: position - 1 ifAbsent:[0]) + 1]] forward: false specialBlock: [:dummy | 1]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:07'! cursorLeft: characterStream "Private - Move cursor left one character if nothing selected, otherwise move cursor to beginning of selection. If the shift key is down, start selecting or extending current selection. Don't allow cursor past beginning of text" self closeTypeIn: characterStream. self moveCursor:[:position | position - 1 max: 1] forward: false specialBlock:[:position | self previousWord: position]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'! cursorPageDown: characterStream self closeTypeIn: characterStream. self moveCursor: [:position | self sameColumn: position newLine:[:lineNo | lineNo + self pageHeight] forward: true] forward: true specialBlock:[:dummy | dummy]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:09'! cursorPageUp: characterStream self closeTypeIn: characterStream. self moveCursor: [:position | self sameColumn: position newLine:[:lineNo | lineNo - self pageHeight] forward: false] forward: false specialBlock:[:dummy | dummy]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 9/19/2002 20:01'! cursorRight: characterStream "Private - Move cursor right one character if nothing selected, otherwise move cursor to end of selection. If the shift key is down, start selecting characters or extending already selected characters. Don't allow cursor past end of text" self closeTypeIn: characterStream. self moveCursor: [:position | position + 1] forward: true specialBlock:[:position | self nextWord: position]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 11/18/2002 17:15'! cursorUp: characterStream "Private - Move cursor from position in current line to same position in prior line. If prior line too short, put at end" self closeTypeIn: characterStream. self moveCursor: [:position | self sameColumn: position newLine:[:line | line - 1] forward: false] forward: false specialBlock:[:dummy | dummy]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'di 12/3/2001 21:49'! escapeToDesktop: characterStream "Pop up a morph to field keyboard input in the context of the desktop" Smalltalk isMorphic ifTrue: [ActiveWorld putUpWorldMenuFromEscapeKey]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'dvf 12/8/2001 00:46'! raiseContextMenu: characterStream "AFAIK, this is never called in morphic, because a subclass overrides it. Which is good, because a ParagraphEditor doesn't know about Morphic and thus duplicates the text-editing actions that really belong in the specific application, not the controller. So the context menu this would raise is likely to be out of date." self yellowButtonActivity. ^true! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/20/2002 11:22'! argAdvance: characterStream "Invoked by Ctrl-a. Useful after Ctrl-q. Search forward from the end of the selection for a colon followed by a space. Place the caret after the space. If none are found, place the caret at the end of the text. Does not affect the undoability of the previous command." | start | sensor keyboard. "flush character" self closeTypeIn: characterStream. start _ paragraph text findString: ': ' startingAt: self stopIndex. start = 0 ifTrue: [start _ paragraph text size + 1]. self selectAt: start + 2. ^true! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 10/21/2003 15:46'! backWord: characterStream "If the selection is not a caret, delete it and leave it in the backspace buffer. Else if there is typeahead, delete it. Else, delete the word before the caret." | startIndex | sensor keyboard. characterStream isEmpty ifTrue: [self hasCaret ifTrue: "a caret, delete at least one character" [startIndex _ 1 max: self markIndex - 1. [startIndex > 1 and: [(paragraph text at: startIndex - 1) asCharacter tokenish]] whileTrue: [startIndex _ startIndex - 1]] ifFalse: "a non-caret, just delete it" [startIndex _ self markIndex]. self backTo: startIndex] ifFalse: [characterStream reset]. ^false! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 18:23'! backspace: characterStream "Backspace over the last character." | startIndex | sensor leftShiftDown ifTrue: [^ self backWord: characterStream]. characterStream isEmpty ifTrue: [startIndex _ self markIndex + (self hasCaret ifTrue: [0] ifFalse: [1]). [sensor keyboardPressed and: [sensor keyboardPeek asciiValue = 8]] whileTrue: [ "process multiple backspaces" sensor keyboard. startIndex _ 1 max: startIndex - 1. ]. self backTo: startIndex] ifFalse: [sensor keyboard. characterStream skip: -1]. ^false! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/20/2002 11:25'! crWithIndent: characterStream "Replace the current text selection with CR followed by as many tabs as on the current line (+/- bracket count) -- initiated by Shift-Return." | char s i tabCount | sensor keyboard. "flush character" s _ paragraph string. i _ self stopIndex. tabCount _ 0. [(i _ i-1) > 0 and: [(char _ s at: i) ~= Character cr]] whileTrue: "Count tabs and brackets (but not a leading bracket)" [(char = Character tab and: [i < s size and: [(s at: i+1) ~= $[ ]]) ifTrue: [tabCount _ tabCount + 1]. char = $[ ifTrue: [tabCount _ tabCount + 1]. char = $] ifTrue: [tabCount _ tabCount - 1]]. characterStream crtab: tabCount. "Now inject CR with tabCount tabs" ^ false! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sw 4/30/2001 21:20'! cursorTopHome: characterStream "Put cursor at beginning of text -- invoked from cmd-H shortcut, useful for keyboards that have no home key." sensor keyboard. self selectAt: 1. ^ true! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/18/2002 11:39'! forwardDelete: characterStream "Delete forward over the next character. Make Undo work on the whole type-in, not just the one char. wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered." | startIndex usel upara uinterval ind stopIndex | startIndex _ self mark. startIndex > paragraph text size ifTrue: [sensor keyboard. ^ false]. self hasSelection ifTrue: ["there was a selection" sensor keyboard. self zapSelectionWith: self nullText. ^ false]. "Null selection - do the delete forward" beginTypeInBlock == nil "no previous typing. openTypeIn" ifTrue: [self openTypeIn. UndoSelection _ self nullText]. uinterval _ UndoInterval deepCopy. upara _ UndoParagraph deepCopy. stopIndex := startIndex. (sensor keyboard asciiValue = 127 and: [sensor leftShiftDown]) ifTrue: [stopIndex := (self nextWord: stopIndex) - 1]. self selectFrom: startIndex to: stopIndex. self replaceSelectionWith: self nullText. self selectFrom: startIndex to: startIndex-1. UndoParagraph _ upara. UndoInterval _ uinterval. UndoMessage selector == #noUndoer ifTrue: [ (UndoSelection isText) ifTrue: [ usel _ UndoSelection. ind _ startIndex. "UndoInterval startIndex" usel replaceFrom: usel size + 1 to: usel size with: (UndoParagraph text copyFrom: ind to: ind). UndoParagraph text replaceFrom: ind to: ind with: self nullText]]. ^false! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 18:25'! querySymbol: characterStream "Invoked by Ctrl-q to query the Symbol table and display alternate symbols. See comment in completeSymbol:lastOffering: for details." sensor keyboard. "flush character" self closeTypeIn: characterStream. "keep typeahead" self hasCaret ifTrue: "Ctrl-q typed when a caret" [self perform: #completeSymbol:lastOffering: withArguments: ((UndoParagraph == paragraph and: [UndoMessage sends: #undoQuery:lastOffering:]) ifTrue: [UndoMessage arguments] "repeated Ctrl-q" ifFalse: [Array with: nil with: nil])] "initial Ctrl-q" ifFalse: "Ctrl-q typed when statements were highlighted" [view flash]. ^true! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'th 9/19/2002 17:34'! simulatedBackspace "Backspace over the last character, derived from hand-char recognition. 2/5/96 sw" | startIndex | startIndex _ self markIndex + (self hasSelection ifTrue: [1] ifFalse: [0]). startIndex _ 1 max: startIndex - 1. self backTo: startIndex. ^ false! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'yo 3/16/2004 13:05'! backTo: startIndex "During typing, backspace to startIndex. Deleted characters fall into three clusters, from left to right in the text: (1) preexisting characters that were backed over; (2) newly typed characters that were backed over (excluding typeahead, which never even appears); (3) preexisting characters that were highlighted before typing began. If typing has not yet been opened, open it and watch for the first and third cluster. If typing has been opened, watch for the first and second cluster. Save characters from the first and third cluster in UndoSelection. Tally characters from the first cluster in UndoMessage's parameter. Delete all the clusters. Do not alter Undoer or UndoInterval (except via openTypeIn). The code is shorter than the comment." | saveLimit newBackovers | saveLimit _ beginTypeInBlock == nil ifTrue: [self openTypeIn. UndoSelection _ self nullText. self stopIndex] ifFalse: [self startOfTyping]. self setMark: startIndex. startIndex < saveLimit ifTrue: [newBackovers _ self startOfTyping - startIndex. beginTypeInBlock _ self startIndex. UndoSelection replaceFrom: 1 to: 0 with: (paragraph text copyFrom: startIndex to: saveLimit - 1). UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers]. self zapSelectionWith: self nullText. self unselect! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 17:40'! closeTypeIn "See comment in openTypeIn. It is important to call closeTypeIn before executing any non-typing key, making a new selection, etc. It is called automatically for menu commands. Typing commands can call 'closeTypeIn: aCharacterStream' instead of this to save typeahead. Undoer & Redoer: undoAndReselect:redoAndReselect:." | begin stop | beginTypeInBlock == nil ifFalse: [(UndoMessage sends: #noUndoer) ifTrue: "should always be true, but just in case..." [begin _ self startOfTyping. stop _ self stopIndex. self undoer: #undoAndReselect:redoAndReselect: with: (begin + UndoMessage argument to: begin + UndoSelection size - 1) with: (stop to: stop - 1). UndoInterval _ begin to: stop - 1]. beginTypeInBlock _ nil]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/17/2002 16:23'! insertTypeAhead: typeAhead typeAhead position = 0 ifFalse: [self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). typeAhead reset. self unselect]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:48'! openTypeIn "Set up UndoSelection to null text (to be added to by readKeyboard and backTo:), beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally how many deleted characters were backspaced over rather than 'cut'. You can't undo typing until after closeTypeIn." beginTypeInBlock == nil ifTrue: [UndoSelection _ self nullText. self undoer: #noUndoer with: 0. beginTypeInBlock _ self startIndex]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/19/2002 18:26'! readKeyboard "Key struck on the keyboard. Find out which one and, if special, carry out the associated special action. Otherwise, add the character to the stream of characters. Undoer & Redoer: see closeTypeIn." | typeAhead char | typeAhead _ WriteStream on: (String new: 128). [sensor keyboardPressed] whileTrue: [self deselect. [sensor keyboardPressed] whileTrue: [char _ sensor keyboardPeek. (self dispatchOnCharacter: char with: typeAhead) ifTrue: [self doneTyping. self setEmphasisHere. ^self selectAndScroll; updateMarker]. self openTypeIn]. self hasSelection ifTrue: "save highlighted characters" [UndoSelection _ self selection]. self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). typeAhead reset. self unselect. sensor keyboardPressed ifFalse: [self selectAndScroll. sensor keyboardPressed ifFalse: [self updateMarker]]]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/18/2002 16:49'! setEmphasisHere emphasisHere _ (paragraph text attributesAt: (self pointIndex - 1 max: 1) forStyle: paragraph textStyle) select: [:att | att mayBeExtended]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'th 9/17/2002 16:23'! simulatedKeystroke: char "Accept char as if it were struck on the keyboard. This version does not yet deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits." self deselect. self openTypeIn. self markBlock = self pointBlock ifFalse: [UndoSelection _ self selection]. self zapSelectionWith: (Text string: char asString emphasis: emphasisHere). self userHasEdited. self unselect. self selectAndScroll. self updateMarker. view ifNotNil: [view topView uncacheBits "in mvc, this makes sure the recognized character shows up in the pane right now; in morphic, a different mechanism is used for the same effect -- see TextMorphEditor method #recognizeCharactersWhileMouseIn:"] ! ! !ParagraphEditor methodsFor: 'undoers' stamp: 'th 9/19/2002 18:46'! undoQuery: hintText lastOffering: selectorOrNil "Undo ctrl-q. selectorOrNil (if not nil) is the previously offered selector. hintText is the original hint. Redoer: completeSymbol." self zapSelectionWith: UndoSelection. self undoMessage: (Message selector: #completeSymbol:lastOffering: arguments: UndoMessage arguments) forRedo: true. self selectAt: self stopIndex! ! !ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/20/2002 11:41'! recomputeInterval "The same characters are selected but their coordinates may have changed." self computeIntervalFrom: self mark to: self pointIndex - 1! ! !ParagraphEditor methodsFor: 'current selection' stamp: 'BG 12/12/2003 12:50'! reverseSelection "Reverse the valence of the current selection highlighting." selectionShowing _ selectionShowing not. paragraph reverseFrom: self pointBlock to: self markBlock! ! !ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:47'! selectAndScroll "Scroll until the selection is in the view and then highlight it." | lineHeight deltaY clippingRectangle endBlock | self select. endBlock _ self stopBlock. lineHeight _ paragraph textStyle lineGrid. clippingRectangle _ paragraph clippingRectangle. deltaY _ endBlock top - clippingRectangle top. deltaY >= 0 ifTrue: [deltaY _ endBlock bottom - clippingRectangle bottom max: 0]. "check if stopIndex below bottom of clippingRectangle" deltaY ~= 0 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) * deltaY sign]! ! !ParagraphEditor methodsFor: 'current selection' stamp: 'th 9/19/2002 18:48'! selectAndScrollToTop "Scroll until the selection is in the view and then highlight it." | lineHeight deltaY clippingRectangle | self select. lineHeight _ paragraph textStyle lineGrid. clippingRectangle _ paragraph clippingRectangle. deltaY _ self stopBlock top - clippingRectangle top. deltaY ~= 0 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) * deltaY sign]! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:37'! adjustSelection: directionBlock "Helper function for Cursor movement. Always moves point thus allowing selections to shrink. " "See also expandSelection:" "Accepts a one argument Block that computes the new postion given an old one." | newPosition | newPosition _ directionBlock value: self pointIndex. self selectMark: self markIndex point: newPosition. ^true.! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 10/28/2003 12:11'! afterSelectionInsertAndSelect: aString self insertAndSelect: aString at: self stopIndex ! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/17/2002 16:11'! computeIntervalFrom: start to: stop "Select the designated characters, inclusive. Make no visual changes." self setMark: start. self setPoint: stop + 1.! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:21'! encompassLine: anInterval "Return an interval that encompasses the entire line" | string left right | string _ paragraph text string. left _ (string lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1. right _ (string indexOf: Character cr startingAt: anInterval last + 1 ifAbsent: [string size + 1]) - 1. ^left to: right! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:50'! selectFrom: start to: stop "Deselect, then select the specified characters inclusive. Be sure the selection is in view." (start = self startIndex and: [stop + 1 = self stopIndex]) ifFalse: [self deselect. self selectInvisiblyFrom: start to: stop]. self selectAndScroll! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:17'! selectInvisiblyMark: mark point: point "Select the designated characters, inclusive. Make no visual changes." ^ self computeIntervalFrom: mark to: point! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 17:17'! selectLine "Make the receiver's selection, if it currently consists of an insertion point only, encompass the current line." self hasSelection ifTrue:[^self]. self selectInterval: (self encompassLine: self selectionInterval)! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 14:18'! selectMark: mark point: point "Deselect, then select the specified characters inclusive. Be sure the selection is in view." (mark = self markIndex and: [point + 1 = self pointIndex]) ifFalse: [self deselect. self selectInvisiblyMark: mark point: point]. self selectAndScroll! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/19/2002 18:49'! selectPrecedingIdentifier "Invisibly select the identifier that ends at the end of the selection, if any." | string sep stop tok | tok _ false. string _ paragraph text string. stop _ self stopIndex - 1. [stop > 0 and: [(string at: stop) isSeparator]] whileTrue: [stop _ stop - 1]. sep _ stop. [sep > 0 and: [(string at: sep) tokenish]] whileTrue: [tok _ true. sep _ sep - 1]. tok ifTrue: [self selectInvisiblyFrom: sep + 1 to: stop]! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'th 9/18/2002 16:51'! selectWord "Select delimited text or word--the result of double-clicking." | openDelimiter closeDelimiter direction match level leftDelimiters rightDelimiters string here hereChar start stop | string _ paragraph text string. here _ self pointIndex. (here between: 2 and: string size) ifFalse: ["if at beginning or end, select entire string" ^self selectFrom: 1 to: string size]. leftDelimiters _ '([{<''" '. rightDelimiters _ ')]}>''" '. openDelimiter _ string at: here - 1. match _ leftDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on left -- match to the right" start _ here. direction _ 1. here _ here - 1. closeDelimiter _ rightDelimiters at: match] ifFalse: [openDelimiter _ string at: here. match _ rightDelimiters indexOf: openDelimiter. match > 0 ifTrue: ["delimiter is on right -- match to the left" stop _ here - 1. direction _ -1. closeDelimiter _ leftDelimiters at: match] ifFalse: ["no delimiters -- select a token" direction _ -1]]. level _ 1. [level > 0 and: [direction > 0 ifTrue: [here < string size] ifFalse: [here > 1]]] whileTrue: [hereChar _ string at: (here _ here + direction). match = 0 ifTrue: ["token scan goes left, then right" hereChar tokenish ifTrue: [here = 1 ifTrue: [start _ 1. "go right if hit string start" direction _ 1]] ifFalse: [direction < 0 ifTrue: [start _ here + 1. "go right if hit non-token" direction _ 1] ifFalse: [level _ 0]]] ifFalse: ["bracket match just counts nesting level" hereChar = closeDelimiter ifTrue: [level _ level - 1"leaving nest"] ifFalse: [hereChar = openDelimiter ifTrue: [level _ level + 1"entering deeper nest"]]]]. level > 0 ifTrue: ["in case ran off string end" here _ here + direction]. direction > 0 ifTrue: [self selectFrom: start to: here - 1] ifFalse: [self selectFrom: here + 1 to: stop]! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 18:48'! againOnce: indices "Find the next occurrence of FindText. If none, answer false. Append the start index of the occurrence to the stream indices, and, if ChangeText is not the same object as FindText, replace the occurrence by it. Note that the search is case-sensitive for replacements, otherwise not." | where | where _ paragraph text findString: FindText startingAt: self stopIndex caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]). where = 0 ifTrue: [^ false]. self deselect; selectInvisiblyFrom: where to: where + FindText size - 1. ChangeText ~~ FindText ifTrue: [self zapSelectionWith: ChangeText]. indices nextPut: where. self selectAndScroll. ^ true! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/18/2002 16:53'! againOrSame: useOldKeys many: many "Subroutine of search: and again. If useOldKeys, use same FindText and ChangeText as before. If many is true, do it repeatedly. Created 1/26/96 sw by adding the many argument to #againOrSame." | home indices wasTypedKey | home _ self selectionInterval. "what was selected when 'again' was invoked" "If new keys are to be picked..." useOldKeys ifFalse: "Choose as FindText..." [FindText _ UndoSelection. "... the last thing replaced." "If the last command was in another paragraph, ChangeText is set..." paragraph == UndoParagraph ifTrue: "... else set it now as follows." [UndoInterval ~= home ifTrue: [self selectInterval: UndoInterval]. "blink" ChangeText _ ((UndoMessage sends: #undoCutCopy:) and: [self hasSelection]) ifTrue: [FindText] "== objects signal no model-locking by 'undo copy'" ifFalse: [self selection]]]. "otherwise, change text is last-replaced text" (wasTypedKey _ FindText size = 0) ifTrue: "just inserted at a caret" [home _ self selectionInterval. self replaceSelectionWith: self nullText. "delete search key..." FindText _ ChangeText] "... and search for it, without replacing" ifFalse: "Show where the search will start" [home last = self selectionInterval last ifFalse: [self selectInterval: home]]. "Find and Change, recording start indices in the array" indices _ WriteStream on: (Array new: 20). "an array to store change locs" [(self againOnce: indices) & many] whileTrue. "<-- this does the work" indices isEmpty ifTrue: "none found" [self flash. wasTypedKey ifFalse: [^self]]. (many | wasTypedKey) ifFalse: "after undo, select this replacement" [home _ self startIndex to: self startIndex + UndoSelection size - 1]. self undoer: #undoAgain:andReselect:typedKey: with: indices contents with: home with: wasTypedKey! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 18:16'! completeSymbol: hintText lastOffering: selectorOrNil "Invoked by Ctrl-q when there is only a caret. Do selector-completion, i.e., try to replace the preceding identifier by a selector that begins with those characters & has as many keywords as possible. Leave two spaces after each colon (only one after the last) as space for arguments. Put the caret after the space after the first keyword. If the user types Ctrl-q again immediately, choose a different selector. Undoer: #undoQuery:lastOffering:; Redoer: itself. If redoing, just redisplay the last offering, selector[OrNil]." | firstTime input prior caret newStart sym kwds outStream | firstTime _ self isRedoing ifTrue: [prior _ sym _ selectorOrNil. true] ifFalse: [hintText isNil]. firstTime ifTrue: "Initial Ctrl-q (or redo)" [caret _ self startIndex. self selectPrecedingIdentifier. input _ self selection] ifFalse: "Repeated Ctrl-q" [caret _ UndoInterval first + hintText size. self selectInvisiblyFrom: UndoInterval first to: UndoInterval last. input _ hintText. prior _ selectorOrNil]. (input size ~= 0 and: [sym ~~ nil or: [(sym _ Symbol thatStarts: input string skipping: prior) ~~ nil]]) ifTrue: "found something to offer" [newStart _ self startIndex. outStream _ WriteStream on: (String new: 2 * sym size). 1 to: (kwds _ sym keywords) size do: [:i | outStream nextPutAll: (kwds at: i). i = 1 ifTrue: [caret _ newStart + outStream contents size + 1]. outStream nextPutAll: (i < kwds size ifTrue: [' '] ifFalse: [' '])]. UndoSelection _ input. self deselect; zapSelectionWith: outStream contents asText. self undoer: #undoQuery:lastOffering: with: input with: sym] ifFalse: "no more matches" [firstTime ifFalse: "restore original text & set up for a redo" [UndoSelection _ self selection. self deselect; zapSelectionWith: input. self undoer: #completeSymbol:lastOffering: with: input with: prior. Undone _ true]. view flash]. self selectAt: caret! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/18/2002 16:49'! exchangeWith: prior "If the prior selection is non-overlapping and legal, exchange the text of it with the current selection and leave the currently selected text selected in the location of the prior selection (or leave a caret after a non-caret if it was exchanged with a caret). If both selections are carets, flash & do nothing. Don't affect the paste buffer. Undoer: itself; Redoer: Undoer." | start stop before selection priorSelection delta altInterval | start _ self startIndex. stop _ self stopIndex - 1. ((prior first <= prior last) | (start <= stop) "Something to exchange" and: [self isDisjointFrom: prior]) ifTrue: [before _ prior last < start. selection _ self selection. priorSelection _ paragraph text copyFrom: prior first to: prior last. delta _ before ifTrue: [0] ifFalse: [priorSelection size - selection size]. self zapSelectionWith: priorSelection. self selectFrom: prior first + delta to: prior last + delta. delta _ before ifTrue: [stop - prior last] ifFalse: [start - prior first]. self zapSelectionWith: selection. altInterval _ prior first + delta to: prior last + delta. self undoer: #exchangeWith: with: altInterval. "If one was a caret, make it otherInterval & leave the caret after the other" prior first > prior last ifTrue: [self selectAt: UndoInterval last + 1]. otherInterval _ start > stop ifTrue: [self selectAt: altInterval last + 1. UndoInterval] ifFalse: [altInterval]] ifFalse: [view flash]! ! !ParagraphEditor methodsFor: 'private' stamp: 'raok 11/15/2001 14:01'! explainDelimitor: string "Is string enclosed in delimitors?" | str | (string at: 1) isLetter ifTrue: [^nil]. "only special chars" (string first = string last) ifTrue: [^ self explainChar: (String with: string first)] ifFalse: [(string first = $( and: [string last = $)]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $[ and: [string last = $]]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = ${ and: [string last = $}]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $< and: [string last = $>]) ifTrue: [^ self explainChar: (String with: string first)]. (string first = $# and: [string last = $)]) ifTrue: [^'"An instance of class Array. The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."']. string first = $# ifTrue: [^'"An instance of class Symbol."']. (string first = $$ and: [string size = 2]) ifTrue: [^'"An instance of class Character. This one is the character ', (String with: string last), '."']. (string first = $:) ifTrue: [str _ string allButFirst. (self explainTemp: str) ~~ nil ifTrue: [^'"An argument to this block will be bound to the temporary variable ', str, '."']]]. ^ nil! ! !ParagraphEditor methodsFor: 'private' stamp: 'cmm 4/9/2004 14:00'! isDisjointFrom: anInterval "Answer true if anInterval is a caret not touching or within the current interval, or if anInterval is a non-caret that does not overlap the current selection." | fudge | fudge _ anInterval size = 0 ifTrue: [1] ifFalse: [0]. ^(anInterval last + fudge < self startIndex or: [anInterval first - fudge >= self stopIndex]) ! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 11/24/2002 17:13'! lines "Other than my member paragraph i compute lines based on logical line breaks, not optical (which may change due to line wrapping of the editor)" | lines string index lineIndex stringSize | string _ paragraph text string. "Empty strings have no lines at all. Think of something." string isEmpty ifTrue:[^{#(1 0 0)}]. stringSize _ string size. lines _ OrderedCollection new: (string size // 15). index _ 0. lineIndex _ 0. string linesDo:[:line | lines addLast: (Array with: (index _ index + 1) with: (lineIndex _ lineIndex + 1) with: (index _ index + line size min: stringSize))]. "Special workaround for last line empty." string last == Character cr "lines last last < stringSize" ifTrue:[lines addLast:{stringSize +1. lineIndex+1. stringSize}]. ^lines! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 19:57'! moveCursor: directionBlock forward: forward specialBlock: specialBlock "Private - Move cursor. directionBlock is a one argument Block that computes the new Position from a given one. specialBlock is a one argumentBlock that computes the new position from a given one under the alternate semantics. Note that directionBlock always is evaluated first." | shift indices newPosition | shift _ sensor leftShiftDown. indices _ self setIndices: shift forward: forward. newPosition _ directionBlock value: (indices at: #moving). (sensor commandKeyPressed or:[sensor controlKeyPressed]) ifTrue: [newPosition _ specialBlock value: newPosition]. sensor keyboard. shift ifTrue: [self selectMark: (indices at: #fixed) point: newPosition - 1] ifFalse: [self selectAt: newPosition]! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/20/2002 11:09'! pageHeight | howManyLines visibleHeight totalHeight ratio | howManyLines _ paragraph numberOfLines. visibleHeight _ self visibleHeight. totalHeight _ self totalTextHeight. ratio _ visibleHeight / totalHeight. ^(ratio * howManyLines) rounded - 2! ! !ParagraphEditor methodsFor: 'private' stamp: 'BG 4/29/2004 11:19'! sameColumn: start newLine: lineBlock forward: isForward "Private - Compute the index in my text with the line number derived from lineBlock," " a one argument block accepting the old line number. The position inside the line will be preserved as good as possible" "The boolean isForward is used in the border case to determine if we should move to the beginning or the end of the line." | wordStyle column currentLine offsetAtTargetLine targetEOL lines numberOfLines currentLineNumber targetLineNumber | wordStyle _ Preferences wordStyleCursorMovement. wordStyle ifTrue: [ lines _ paragraph lines. numberOfLines := paragraph numberOfLines. currentLineNumber _ paragraph lineIndexOfCharacterIndex: start. currentLine _ lines at: currentLineNumber] ifFalse: [ lines _ self lines. numberOfLines := lines size. currentLine _ lines detect:[:lineInterval | lineInterval last >= start] ifNone:[lines last]. currentLineNumber _ currentLine second]. column _ start - currentLine first. targetLineNumber _ ((lineBlock value: currentLineNumber) max: 1) min: numberOfLines. offsetAtTargetLine _ (lines at: targetLineNumber) first. targetEOL _ (lines at: targetLineNumber) last + (targetLineNumber == numberOfLines ifTrue:[1]ifFalse:[0]). targetLineNumber == currentLineNumber "No movement or movement failed. Move to beginning or end of line." ifTrue:[^isForward ifTrue:[targetEOL] ifFalse:[offsetAtTargetLine]]. ^offsetAtTargetLine + column min: targetEOL.! ! !ParagraphEditor methodsFor: 'private' stamp: 'th 9/19/2002 19:02'! setIndices: shiftPressed forward: forward "Little helper method that sets the moving and fixed indices according to some flags." | indices | indices _ Dictionary new. (shiftPressed and:[Preferences selectionsMayShrink]) ifTrue: [ indices at: #moving put: self pointIndex. indices at: #fixed put: self markIndex ] ifFalse: [ forward ifTrue:[ indices at: #moving put: self stopIndex. indices at: #fixed put: self startIndex. ] ifFalse: [ indices at: #moving put: self startIndex. indices at: #fixed put: self stopIndex. ] ]. ^indices! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'vb 8/13/2001 23:41'! compileSelectionFor: anObject in: evalContext | methodNode method | methodNode _ [Compiler new compileNoPattern: self selectionAsStream in: anObject class context: evalContext notifying: self ifFail: [^nil]] on: OutOfScopeNotification do: [:ex | ex resume: true]. method _ methodNode generate: #(0 0 0 0). ^method copyWithTempNames: methodNode tempNames! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'NS 1/28/2004 11:19'! debug: aCompiledMethod receiver: anObject in: evalContext | selector guineaPig debugger context | selector _ evalContext isNil ifTrue: [#DoIt] ifFalse: [#DoItIn:]. anObject class addSelectorSilently: selector withMethod: aCompiledMethod. guineaPig _ evalContext isNil ifTrue: [[anObject DoIt] newProcess] ifFalse: [[anObject DoItIn: evalContext] newProcess]. context _ guineaPig suspendedContext. debugger _ Debugger new process: guineaPig controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: context isolationHead: nil. debugger openFullNoSuspendLabel: 'Debug it'. [debugger interruptedContext method == aCompiledMethod] whileFalse: [debugger send]. anObject class basicRemoveSelector: selector! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'vb 8/13/2001 23:38'! debugIt | method receiver context | (model respondsTo: #doItReceiver) ifTrue: [FakeClassPool adopt: model selectedClass. receiver _ model doItReceiver. context _ model doItContext] ifFalse: [receiver _ context _ nil]. self lineSelectAndEmptyCheck: [^self]. method _ self compileSelectionFor: receiver in: context. method notNil ifTrue: [self debug: method receiver: receiver in: context]. FakeClassPool adopt: nil! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'gk 3/3/2004 17:15'! evaluateSelection "Treat the current selection as an expression; evaluate it and return the result" | result rcvr ctxt | self lineSelectAndEmptyCheck: [^ '']. (model respondsTo: #doItReceiver) ifTrue: [FakeClassPool adopt: model selectedClass. "Include model pool vars if any" rcvr _ model doItReceiver. ctxt _ model doItContext] ifFalse: [rcvr _ ctxt _ nil]. result _ [ rcvr class evaluatorClass new evaluate: self selectionAsStream in: ctxt to: rcvr notifying: self ifFail: [FakeClassPool adopt: nil. ^ #failedDoit] logged: true. ] on: OutOfScopeNotification do: [ :ex | ex resume: true]. FakeClassPool adopt: nil. ^ result! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'sd 4/16/2003 11:41'! objectsReferencingIt "Open a list inspector on all objects that reference the object that results when the current selection is evaluated. " | result | self terminateAndInitializeAround: [ result _ self evaluateSelection. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [view flash] ifFalse: [self systemNavigation browseAllObjectReferencesTo: result except: #() ifNone: [:obj | view topView flash]]. ]! ! !ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'BG 6/1/2003 09:43'! offerMenuFromEsc: aStream sensor keyboard. " consume the character " self yellowButtonActivity. ^true "tell the caller that the character was processed "! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'! hasCaret ^self markBlock = self pointBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:22'! hasSelection ^self hasCaret not! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:13'! mark ^ self markBlock stringIndex! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! markBlock ^ stopBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! markBlock: aCharacterBlock stopBlock _ aCharacterBlock. ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'! markIndex ^ self markBlock stringIndex! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! pointBlock ^ startBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 10/21/2003 15:49'! pointBlock: aCharacterBlock startBlock _ aCharacterBlock. ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 12:31'! pointIndex ^ self pointBlock stringIndex! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'yo 7/31/2004 16:27'! selection "Answer the text in the paragraph that is currently selected." | t | t _ paragraph text copyFrom: self startIndex to: self stopIndex - 1. t string isOctetString ifTrue: [t asOctetStringText]. ^ t. ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:10'! selectionAsStream "Answer a ReadStream on the text in the paragraph that is currently selected." ^ReadWriteStream on: paragraph string from: self startIndex to: self stopIndex - 1! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 16:18'! selectionInterval "Answer the interval that is currently selected." ^self startIndex to: self stopIndex - 1 ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'! setMark: anIndex self markBlock: (paragraph characterBlockForIndex: anIndex) ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:02'! setPoint: anIndex self pointBlock: (paragraph characterBlockForIndex: anIndex) ! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:10'! startBlock ^ self pointBlock min: self markBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'! startBlock: aCharacterBlock self markBlock: aCharacterBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'! startIndex ^ self startBlock stringIndex! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:14'! stopBlock ^ self pointBlock max: self markBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 13:10'! stopBlock: aCharacterBlock self pointBlock: aCharacterBlock! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/18/2002 14:27'! stopIndex ^ self stopBlock stringIndex! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/17/2002 16:23'! unselect self markBlock: self pointBlock copy.! ! !ParagraphEditor methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:12'! zapSelectionWith: aText "Deselect, and replace the selection text by aText. Remember the resulting selectionInterval in UndoInterval and otherInterval. Do not set up for undo." | start stop | self deselect. start _ self startIndex. stop _ self stopIndex. (aText isEmpty and: [stop > start]) ifTrue: ["If deleting, then set emphasisHere from 1st character of the deletion" emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle) select: [:att | att mayBeExtended]]. (start = stop and: [aText size = 0]) ifFalse: [paragraph replaceFrom: start to: stop - 1 with: aText displaying: true. self computeIntervalFrom: start to: start + aText size - 1. UndoInterval _ otherInterval _ self selectionInterval]! ! !ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'! blinkParenAt: parenLocation self text addAttribute: TextEmphasis bold from: parenLocation to: parenLocation. lastParentLocation _ parenLocation.! ! !ParagraphEditor methodsFor: 'parenblinking' stamp: 'AB 1/7/2002 04:03'! blinkPrevParen | openDelimiter closeDelimiter level string here hereChar | string _ paragraph text string. here _ startBlock stringIndex. openDelimiter _ sensor keyboardPeek. closeDelimiter _ '([{' at: (')]}' indexOf: openDelimiter). level _ 1. [level > 0 and: [here > 2]] whileTrue: [hereChar _ string at: (here _ here - 1). hereChar = closeDelimiter ifTrue: [level _ level - 1. level = 0 ifTrue: [^ self blinkParenAt: here]] ifFalse: [hereChar = openDelimiter ifTrue: [level _ level + 1]]].! ! !ParagraphEditor methodsFor: 'parenblinking' stamp: 'mir 8/3/2004 13:31'! clearParens lastParentLocation ifNotNil: [self text string size >= lastParentLocation ifTrue: [ self text removeAttribute: TextEmphasis bold from: lastParentLocation to: lastParentLocation]] ! ! !ParagraphEditor methodsFor: 'parenblinking' stamp: 'yo 5/28/2004 10:17'! dispatchOnCharacter: char with: typeAheadStream "Carry out the action associated with this character, if any. Type-ahead is passed so some routines can flush or use it." | honorCommandKeys | self clearParens. char asciiValue = 13 ifTrue: [ ^ sensor controlKeyPressed ifTrue: [self crWithIndent: typeAheadStream] ifFalse: [self normalCharacter: typeAheadStream]]. ((honorCommandKeys _ Preferences cmdKeysInText) and: [char = Character enter]) ifTrue: [^ self dispatchOnEnterWith: typeAheadStream]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this conflict, assume that keys other than cursor keys aren't used together with Crtl." ((self class specialShiftCmdKeys includes: char asciiValue) and: [char asciiValue < 27]) ifTrue: [^ sensor controlKeyPressed ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]]. "backspace, and escape keys (ascii 8 and 27) are command keys" ((honorCommandKeys and: [sensor commandKeyPressed]) or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue: [^ sensor leftShiftDown ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]]. "the control key can be used to invoke shift-cmd shortcuts" (honorCommandKeys and: [sensor controlKeyPressed]) ifTrue: [^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]. (')]}' includes: char) ifTrue: [self blinkPrevParen]. ^ self perform: #normalCharacter: with: typeAheadStream! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 9/5/2003 19:02'! initializeTextEditorMenus "Initialize the yellow button pop-up menu and corresponding messages." "ParagraphEditor initializeTextEditorMenus" TextEditorYellowButtonMenu _ SelectionMenu fromArray: { {'find...(f)' translated. #find}. {'find again (g)' translated. #findAgain}. {'set search string (h)' translated. #setSearchString}. #-. {'do again (j)' translated. #again}. {'undo (z)' translated. #undo}. #-. {'copy (c)' translated. #copySelection}. {'cut (x)' translated. #cut}. {'paste (v)' translated. #paste}. {'paste...' translated. #pasteRecent}. #-. {'do it (d)' translated. #doIt}. {'print it (p)' translated. #printIt}. {'inspect it (i)' translated. #inspectIt}. {'explore it (I)' translated. #exploreIt}. {'debug it' translated. #debugIt}. #-. {'accept (s)' translated. #accept}. {'cancel (l)' translated. #cancel}. #-. {'show bytecodes' translated. #showBytecodes}. #-. {'more...' translated. #shiftedTextPaneMenuRequest}. } ! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'dgd 9/5/2003 18:52'! shiftedYellowButtonMenu "Answer the menu to be presented when the yellow button is pressed while the shift key is down" ^ SelectionMenu fromArray: { {'set font... (k)' translated. #offerFontMenu}. {'set style... (K)' translated. #changeStyle}. {'set alignment...' translated. #chooseAlignment}. #-. {'explain' translated. #explain}. {'pretty print' translated. #prettyPrint}. {'pretty print with color' translated. #prettyPrintWithColor}. {'file it in (G)' translated. #fileItIn}. {'tiles from it' translated. #selectionAsTiles}. {'recognizer (r)' translated. #recognizeCharacters}. {'spawn (o)' translated. #spawn}. #-. {'definition of word' translated. #wordDefinition}. {'verify spelling of word' translated. #verifyWordSpelling}. {'translate it' translated. #translateIt}. {'choose language' translated. #languagePrefs}. #-. {'browse it (b)' translated. #browseIt}. {'senders of it (n)' translated. #sendersOfIt}. {'implementors of it (m)' translated. #implementorsOfIt}. {'references to it (N)' translated. #referencesToIt}. #-. {'selectors containing it (W)' translated. #methodNamesContainingIt}. {'method strings with it (E)' translated. #methodStringsContainingit}. {'method source with it' translated. #methodSourceContainingIt}. {'class names containing it' translated. #classNamesContainingIt}. {'class comments with it' translated. #classCommentsContainingIt}. {'change sets with it' translated. #browseChangeSetsWithSelector}. #-. {'save contents to file...' translated. #saveContentsInFile}. {'send contents to printer' translated. #sendContentsToPrinter}. {'printer setup' translated. #printerSetup}. #-. {'special menu...' translated. #presentSpecialMenu}. {'more...' translated. #yellowButtonActivity}. } ! ! !ParagraphEditor class methodsFor: 'instance creation' stamp: 'nk 9/3/2004 14:10'! new "Answer a new instance of me with a null Paragraph to be edited." | aParagraphEditor | aParagraphEditor _ super new. aParagraphEditor changeParagraph: '' asParagraph. ^aParagraphEditor! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sw 12/7/2001 22:54'! initializeCmdKeyShortcuts "Initialize the (unshifted) command-key (or alt-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "ParagraphEditor initialize" | cmdMap cmds | cmdMap := Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: 1 + 1 put: #cursorHome:. "home key" cmdMap at: 4 + 1 put: #cursorEnd:. "end key" cmdMap at: 8 + 1 put: #backspace:. "ctrl-H or delete key" cmdMap at: 11 + 1 put: #cursorPageUp:. "page up key" cmdMap at: 12 + 1 put: #cursorPageDown:. "page down key" cmdMap at: 13 + 1 put: #crWithIndent:. "cmd-Return" cmdMap at: 27 + 1 put: #offerMenuFromEsc:. "escape key" cmdMap at: 28 + 1 put: #cursorLeft:. "left arrow key" cmdMap at: 29 + 1 put: #cursorRight:. "right arrow key" cmdMap at: 30 + 1 put: #cursorUp:. "up arrow key" cmdMap at: 31 + 1 put: #cursorDown:. "down arrow key" cmdMap at: 32 + 1 put: #selectWord:. "space bar key" cmdMap at: 127 + 1 put: #forwardDelete:. "del key" '0123456789-=' do: [:char | cmdMap at: char asciiValue + 1 put: #changeEmphasis:]. '([{''"<' do: [:char | cmdMap at: char asciiValue + 1 put: #enclose:]. cmdMap at: $, asciiValue + 1 put: #shiftEnclose:. cmds := #($a #selectAll: $b #browseIt: $c #copySelection: $d #doIt: $e #exchange: $f #find: $g #findAgain: $h #setSearchString: $i #inspectIt: $j #doAgainOnce: $k #offerFontMenu: $l #cancel: $m #implementorsOfIt: $n #sendersOfIt: $o #spawnIt: $p #printIt: $q #querySymbol: $r #recognizer: $s #save: $t #tempCommand: $u #align: $v #paste: $w #backWord: $x #cut: $y #swapChars: $z #undo:). 1 to: cmds size by: 2 do: [:i | cmdMap at: (cmds at: i) asciiValue + 1 put: (cmds at: i + 1)]. CmdActions := cmdMap! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sw 12/9/2001 21:33'! initializeShiftCmdKeyShortcuts "Initialize the shift-command-key (or control-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the capitalized versions of the letters. TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." | cmdMap cmds | "shift-command and control shortcuts" cmdMap _ Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key" cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return" cmdMap at: (27 + 1) put: #offerMenuFromEsc:. "escape key" cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" cmdMap at: (32 + 1) put: #selectWord:. "space bar key" cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus" cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus" cmdMap at: (127 + 1) put: #forwardDelete:. "del key" "Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $(" '9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose: ]. "({< and double-quote" "Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command." "NB: sw 12/9/2001 commented out the idiosyncratic line just below, which was grabbing shift-esc in the text editor and hence which argued with the wish to have shift-esc be a universal gesture for escaping the local context and calling up the desktop menu." "cmdMap at: (27 + 1) put: #shiftEnclose:." "ctrl-[" "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]." cmds _ #( $a argAdvance: $b browseItHere: $c compareToClipboard: $d duplicate: $e methodStringsContainingIt: $f displayIfFalse: $g fileItIn: $h cursorTopHome: $i exploreIt: $j doAgainMany: $k changeStyle: $l outdent: $m selectCurrentTypeIn: $n referencesToIt: $p makeProjectLink: $r indent: $s search: $t displayIfTrue: $u changeLfToCr: $v pasteInitials: $w methodNamesContainingIt: $x makeLowercase: $y makeUppercase: $z makeCapitalized: ). 1 to: cmds size by: 2 do: [ :i | cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys" cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys" cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys" ]. ShiftCmdActions _ cmdMap! ! !ParameterTile methodsFor: 'access' stamp: 'sw 3/15/2005 21:45'! isBoolean "Answer whether the receiver's type is inherently boolean" ^ self scriptEditor typeForParameter == #Boolean! ! !ParameterTile methodsFor: 'access' stamp: 'sw 3/15/2005 22:36'! rowOfRightTypeFor: aLayoutMorph forActor: aPlayer "Answer a phrase of the right type for the putative container" | aTemporaryViewer aPhrase | aLayoutMorph demandsBoolean ifTrue: [aTemporaryViewer _ CategoryViewer new invisiblySetPlayer: aPlayer. aPhrase _ aTemporaryViewer booleanPhraseFromPhrase: self. aPhrase justGrabbedFromViewer: false. ^ aPhrase]. ^ self! ! !ParameterTile methodsFor: 'access' stamp: 'sw 1/18/2004 22:12'! scriptEditor "Answer the receiver's script editor. The slightly strange code here is in order to contend with the unusual situation where a parameter tile obtained from one script editor is later dropped into a different script editor. As long as the parameter tile is *in* a script editor, that containing scriptEditor is the one; if it is *not*, then we use the last known one" | aScriptEditor | ^ (aScriptEditor _ self outermostMorphThat: [:m | m isKindOf: ScriptEditorMorph]) ifNotNil: [scriptEditor _ aScriptEditor] ifNil: [scriptEditor]! ! !ParameterTile methodsFor: 'accessing' stamp: 'sw 7/18/2002 02:45'! resultType "Answer the result type of the receiver" ^ self scriptEditor typeForParameter! ! !ParameterTile methodsFor: 'code generation' stamp: 'yo 12/20/2003 02:49'! storeCodeOn: aStream indent: tabCount "Store code on the stream" | myTypeString | myTypeString _ self resultType. (self scriptEditor hasParameter and: [self scriptEditor typeForParameter = myTypeString]) ifTrue: [aStream nextPutAll: 'parameter'] ifFalse: ["This script no longer bears a parameter, yet there's an orphaned Parameter tile in it" aStream nextPutAll: '(self defaultValueOfType: #', myTypeString, ')']! ! !ParameterTile methodsFor: 'initialization' stamp: 'yo 3/14/2005 08:01'! forScriptEditor: aScriptEditor "Make the receiver be associated with the given script editor" scriptEditor _ aScriptEditor. self line1: aScriptEditor typeForParameter translated.! ! !ParameterTile methodsFor: 'initialization' stamp: 'dgd 3/7/2003 15:45'! initialize "initialize the state of the receiver" super initialize. "" self typeColor: Color red! ! !ParameterTile methodsFor: 'type' stamp: 'sw 7/22/2002 17:48'! assureTypeStillValid "Consider the possibility that the parameter type of my surrounding method has changed and that hence I no longer represent a possible value for the parameter of the script. If this condition obtains, then banish me in favor of a default literal tile of the correct type" (self ownerThatIsA: TilePadMorph) ifNotNilDo: [:aPad | aPad type = self scriptEditor typeForParameter ifFalse: [aPad setToBearDefaultLiteral]]! ! !ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 21:55'! associatedPlayer "Answer the player with which the receiver is associated" ^ self scriptEditor playerScripted! ! !ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 22:37'! booleanComparatorPhrase "Answer a boolean-valued phrase derived from a retriever (e.g. 'car's heading'); this is in order to assure that tiles laid down in a TEST area will indeed produce a boolean result" | outerPhrase rel retrieverType | retrieverType _ self resultType. rel _ (Vocabulary vocabularyForType: retrieverType) comparatorForSampleBoolean. outerPhrase _ PhraseTileMorph new setOperator: rel type: #Boolean rcvrType: retrieverType argType: retrieverType. outerPhrase firstSubmorph addMorph: self. outerPhrase submorphs last addMorph: (ScriptingSystem tileForArgType: retrieverType). outerPhrase submorphs second submorphs last setBalloonText: (ScriptingSystem helpStringForOperator: rel). ^ outerPhrase! ! !ParameterTile methodsFor: 'miscellaneous' stamp: 'sw 3/15/2005 22:41'! tileRows "Answer a list of tile rows -- in this case exactly one row -- representing the receiver." ^ Array with: (Array with: self)! ! !ParameterTile commentStamp: '<historical>' prior: 0! Represents a parameter in a user-defined script in "classic" tile-scripting. The type of a script's parameter is declared in the ScriptEditor for the script, and a parameter tile gets its type from the script. But because the user can change the parameter type *after* having created parameter tiles, we can later have type mismatches. Which however we at least deal with reasonably cleverly.! !ParseNode methodsFor: 'testing' stamp: 'ls 1/29/2004 21:11'! isJust: node ^false! ! !ParseNode methodsFor: 'code generation' stamp: 'nk 7/10/2004 10:04'! pc "Used by encoder source mapping." ^pc ifNil: [ 0 ] ! ! !ParseNode methodsFor: 'printing' stamp: 'ab 7/13/2004 13:46'! printCommentOn: aStream indent: indent | thisComment | self comment == nil ifTrue: [^ self]. aStream withStyleFor: #comment do: [1 to: self comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment _ self comment at: index. self printSingleComment: thisComment on: aStream indent: indent. aStream nextPut: $"]]. self comment: nil! ! !ParseNode methodsFor: 'private' stamp: 'ls 1/29/2004 21:17'! ifNilReceiver "assuming this object is the receiver of an ifNil:, what object is being asked about?" ^self! ! !ParseNode methodsFor: 'private' stamp: 'nk 7/11/2004 13:39'! printSingleComment: aString on: aStream indent: indent "Print the comment string, assuming it has been indented indent tabs. Break the string at word breaks, given the widths in the default font, at 450 points." | readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar | readStream _ ReadStream on: aString. font _ TextStyle default defaultFont. tabWidth _ TextConstants at: #DefaultTab. spaceWidth _ font widthOf: Character space. position _ indent * tabWidth. lineBreak _ 450. [readStream atEnd] whileFalse: [word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc]. wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)]. position _ position + wordWidth. position > lineBreak ifTrue: [aStream skip: -1; crtab: indent. position _ indent * tabWidth + wordWidth + spaceWidth. lastChar = Character cr ifTrue: [[readStream peekFor: Character tab] whileTrue]. word isEmpty ifFalse: [aStream nextPutAll: word; space]] ifFalse: [aStream nextPutAll: word. readStream atEnd ifFalse: [position _ position + spaceWidth. aStream space]. lastChar = Character cr ifTrue: [aStream skip: -1; crtab: indent. position _ indent * tabWidth. [readStream peekFor: Character tab] whileTrue]]]! ! !ParseNode methodsFor: 'tiles' stamp: 'ab 7/13/2004 13:47'! addCommentToMorph: aMorph | row | (self comment isNil or: [self comment isEmpty]) ifTrue: [^ self]. row _ aMorph addTextRow: (String streamContents: [:strm | self printCommentOn: strm indent: 1]). row firstSubmorph color: (SyntaxMorph translateColor: #comment). row parseNode: (self as: CommentNode). ! ! !ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/12/2002 11:10'! blockReturnCode ^ EndRemote! ! !ParseNode class methodsFor: 'class initialization' stamp: 'ajh 8/6/2002 12:04'! popCode ^ Pop! ! !Parser methodsFor: 'public access' stamp: 'ajh 1/22/2003 16:51'! parse: sourceStreamOrString class: behavior ^ self parse: sourceStreamOrString readStream class: behavior noPattern: false context: nil notifying: nil ifFail: [self parseError]! ! !Parser methodsFor: 'public access' stamp: 'ajh 6/22/2003 22:48'! parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock "Answer a MethodNode for the argument, sourceStream, that is the root of a parse tree. Parsing is done with respect to the argument, class, to find instance, class, and pool variables; and with respect to the argument, ctxt, to find temporary variables. Errors in parsing are reported to the argument, req, if not nil; otherwise aBlock is evaluated. The argument noPattern is a Boolean that is true if the the sourceStream does not contain a method header (i.e., for DoIts)." | methNode repeatNeeded myStream parser s p | (req notNil and: [RequestAlternateSyntaxSetting signal and: [(sourceStream isKindOf: FileStream) not]]) ifTrue: [parser _ self as: DialectParser] ifFalse: [parser _ self]. myStream _ sourceStream. [repeatNeeded _ false. p _ myStream position. s _ myStream upToEnd. myStream position: p. parser init: myStream notifying: req failBlock: [^ aBlock value]. doitFlag _ noPattern. failBlock_ aBlock. [methNode _ parser method: noPattern context: ctxt encoder: (Encoder new init: class context: ctxt notifying: parser)] on: ParserRemovedUnusedTemps do: [ :ex | repeatNeeded _ (requestor isKindOf: TextMorphEditor) not. myStream _ ReadStream on: requestor text string. ex resume]. repeatNeeded] whileTrue. encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow" methNode sourceText: s. ^ methNode! ! !Parser methodsFor: 'expression types' stamp: 'hmm 7/16/2001 18:47'! assignment: varNode " var '_' expression => AssignmentNode." | loc start | (loc _ varNode assignmentCheck: encoder at: prevMark + requestorOffset) >= 0 ifTrue: [^self notify: 'Cannot store into' at: loc]. start _ self startOfNextToken. varNode nowHasDef. self advance. self expression ifFalse: [^self expected: 'Expression']. parseNode _ AssignmentNode new variable: varNode value: parseNode from: encoder sourceRange: (start to: self endOfLastToken). ^true! ! !Parser methodsFor: 'expression types' stamp: 'hmm 7/17/2001 21:03'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | variableNodes temporaryBlockVariables start | variableNodes _ OrderedCollection new. start _ prevMark + requestorOffset. "Gather parameters." [self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)]. (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar']. temporaryBlockVariables _ self temporaryBlockVariables. self statements: variableNodes innerBlock: true. parseNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. encoder noteSourceRange: (self endOfLastToken to: self endOfLastToken) forNode: parseNode. "The scope of the parameters and temporary block variables is no longer active." temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]! ! !Parser methodsFor: 'expression types' stamp: 'yo 8/30/2002 14:41'! messagePart: level repeat: repeat | start receiver selector args precedence words keywordStart | [receiver _ parseNode. (hereType == #keyword and: [level >= 3]) ifTrue: [start _ self startOfNextToken. selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. words _ OrderedCollection new. [hereType == #keyword] whileTrue: [keywordStart _ self startOfNextToken + requestorOffset. selector nextPutAll: self advance. words addLast: (keywordStart to: self endOfLastToken + requestorOffset). self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 2 repeat: true. args addLast: parseNode]. (Symbol hasInterned: selector contents ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector contents wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 3] ifFalse: [((hereType == #binary or: [hereType == #verticalBar]) and: [level >= 2]) ifTrue: [start _ self startOfNextToken. selector _ self advance asOctetString asSymbol. self primaryExpression ifFalse: [^self expected: 'Argument']. self messagePart: 1 repeat: true. args _ Array with: parseNode. precedence _ 2] ifFalse: [hereType == #word ifTrue: [start _ self startOfNextToken. selector _ self advance. args _ #(). words _ OrderedCollection with: (start + requestorOffset to: self endOfLastToken + requestorOffset). (Symbol hasInterned: selector ifTrue: [ :sym | selector _ sym]) ifFalse: [ selector _ self correctSelector: selector wordIntervals: words exprInterval: (start to: self endOfLastToken) ifAbort: [ ^ self fail ] ]. precedence _ 1] ifFalse: [^args notNil]]]. parseNode _ MessageNode new receiver: receiver selector: selector arguments: args precedence: precedence from: encoder sourceRange: (start to: self endOfLastToken). repeat] whileTrue: []. ^true! ! !Parser methodsFor: 'expression types' stamp: 'sw 9/6/2001 15:30'! temporaries " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ (prevEnd ifNil: [0]) + 1. tempsMark _ hereMark "formerly --> prevMark + prevToken". tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #verticalBar) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 20:12'! advance | this | prevMark _ hereMark. prevEnd _ hereEnd. this _ here. here _ token. hereType _ tokenType. hereMark _ mark. hereEnd _ source position - (source atEnd ifTrue: [hereChar == 30 asCharacter ifTrue: [0] ifFalse: [1]] ifFalse: [2]). self scanToken. "Transcript show: 'here: ', here printString, ' mark: ', hereMark printString, ' end: ', hereEnd printString; cr." ^this! ! !Parser methodsFor: 'scanning' stamp: 'hmm 7/16/2001 19:23'! endOfLastToken ^ prevEnd ifNil: [mark]! ! !Parser methodsFor: 'error handling' stamp: 'hmm 7/18/2001 21:45'! expected: aString "Notify a problem at token 'here'." tokenType == #doIt ifTrue: [hereMark _ hereMark + 1]. hereType == #doIt ifTrue: [hereMark _ hereMark + 1]. ^ self notify: aString , ' expected' at: hereMark + requestorOffset! ! !Parser methodsFor: 'error handling' stamp: 'LC 1/6/2002 14:30'! notify: string at: location requestor isNil ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. SyntaxErrorNotification inClass: encoder classEncoding withCode: (source contents copyReplaceFrom: location to: location - 1 with: string , ' ->') doitFlag: doitFlag] ifFalse: [requestor notify: string , ' ->' at: location in: source]. ^self fail! ! !Parser methodsFor: 'error correction' stamp: 'yo 8/28/2002 22:32'! correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." | alternatives aStream choice correctSelector userSelection lines firstLine | "If we can't ask the user, assume that the keyword will be defined later" self interactive ifFalse: [ ^ proposedKeyword asSymbol ]. userSelection _ requestor selectionInterval. requestor selectFrom: spots first first to: spots last last. requestor select. alternatives _ Symbol possibleSelectorsFor: proposedKeyword. self flag: #toBeFixed. "alternatives addAll: (MultiSymbol possibleSelectorsFor: proposedKeyword)." aStream _ WriteStream on: (String new: 200). aStream nextPutAll: (proposedKeyword contractTo: 35); cr. firstLine _ 1. alternatives do: [:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr]. aStream nextPutAll: 'cancel'. lines _ Array with: firstLine with: (alternatives size + firstLine). choice _ (PopUpMenu labels: aStream contents lines: lines) startUpWithCaption: 'Unknown selector, please confirm, correct, or cancel'. (choice = 0) | (choice > (lines at: 2)) ifTrue: [ ^ abortAction value ]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ]. correctSelector _ alternatives at: choice - 1. self substituteSelector: correctSelector keywords wordIntervals: spots. ((proposedKeyword last ~= $:) and: [correctSelector last == $:]) ifTrue: [ ^ abortAction value]. ^ correctSelector. ! ! !Parser methodsFor: 'error correction' stamp: 'kfr 9/22/2004 21:12'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps or inst-vars, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable. rr 3/4/2004 10:26 : adds the option to define a new class. " | tempIvar labels actions lines alternatives binding userSelection choice action | "Check if this is an i-var, that has been corrected already (ugly)" (encoder classEncoding allInstVarNames includes: proposedVariable) ifTrue: [ ^LiteralVariableNode new name: proposedVariable index: (encoder classEncoding allInstVarNames indexOf: proposedVariable) - 1 type: 1; yourself ]. "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [ ^encoder undeclared: proposedVariable ]. "First check to see if the requestor knows anything about the variable" tempIvar _ proposedVariable first canBeNonGlobalVarInitial. (tempIvar and: [ (binding _ requestor bindingOf: proposedVariable) notNil ]) ifTrue: [ ^encoder global: binding name: proposedVariable ]. userSelection _ requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. "Build the menu with alternatives" labels _ OrderedCollection new. actions _ OrderedCollection new. lines _ OrderedCollection new. alternatives _ encoder possibleVariablesFor: proposedVariable. tempIvar ifTrue: [ labels add: 'declare temp'. actions add: [ self declareTempAndPaste: proposedVariable ]. labels add: 'declare instance'. actions add: [ self declareInstVar: proposedVariable ] ] ifFalse: [ labels add: 'define new class'. actions add: [self defineClass: proposedVariable]. labels add: 'declare global'. actions add: [ self declareGlobal: proposedVariable ]. encoder classEncoding == UndefinedObject ifFalse: [ labels add: 'declare class variable'. actions add: [ self declareClassVar: proposedVariable ] ] ]. lines add: labels size. alternatives do: [ :each | labels add: each. actions add: [ self substituteWord: each wordInterval: spot offset: 0. encoder encodeVariable: each ] fixTemps ]. lines add: labels size. labels add: 'cancel'. "Display the pop-up menu" choice _ (PopUpMenu labelArray: labels asArray lines: lines asArray) startUpWithCaption: 'Unknown variable: ', proposedVariable, ' please correct, or cancel:'. action _ actions at: choice ifAbsent: [ ^self fail ]. "Execute the selected action" requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. ^action value! ! !Parser methodsFor: 'error correction' stamp: 'rr 3/6/2004 16:07'! declareInstVar: name " rr 3/6/2004 16:06 : adds the line to correctly compute the index. uncommented the option in the caller." | index | encoder classEncoding addInstVarName: name. index _ encoder classEncoding instVarNames indexOf: name. encoder classEncoding allSuperclassesDo: [:cls | index := index + cls instVarNames size]. ^LiteralVariableNode new name: name index: index - 1 type: 1; yourself ! ! !Parser methodsFor: 'error correction' stamp: 'RAA 6/5/2001 11:57'! declareTempAndPaste: name | insertion delta theTextString characterBeforeMark | theTextString _ requestor text string. characterBeforeMark _ theTextString at: tempsMark-1 ifAbsent: [$ ]. (theTextString at: tempsMark) = $| ifTrue: [ "Paste it before the second vertical bar" insertion _ name, ' '. characterBeforeMark isSeparator ifFalse: [ insertion _ ' ', insertion]. delta _ 0. ] ifFalse: [ "No bars - insert some with CR, tab" insertion _ '| ' , name , ' |',String cr. delta _ 2. "the bar and CR" characterBeforeMark = Character tab ifTrue: [ insertion _ insertion , String tab. delta _ delta + 1. "the tab" ]. ]. tempsMark _ tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0) - delta. ^ encoder bindAndJuggle: name! ! !Parser methodsFor: 'error correction' stamp: 'rr 3/4/2004 10:57'! defineClass: className "prompts the user to define a new class, asks for it's category, and lets the users edit further the definition" | sym cat def d2 | sym := className asSymbol. cat := FillInTheBlank request: 'Enter class category : ' initialAnswer: 'Unknown'. cat ifEmpty: [cat := 'Unknown']. def := 'Object subclass: #', sym, ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , cat, ''''. d2 := FillInTheBlank request: 'Edit class definition : ' initialAnswer: def. d2 ifEmpty: [d2 := def]. Compiler evaluate: d2. ^ encoder global: (Smalltalk associationAt: sym) name: sym! ! !Parser methodsFor: 'error correction' stamp: 'tween 6/28/2004 09:23'! removeUnusedTemps "Scan for unused temp names, and prompt the user about the prospect of removing each one found" | str end start madeChanges | madeChanges _ false. str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | ((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption: ((temp , ' appears to be unused in this method. OK to remove it?') asText makeBoldFrom: 1 to: temp size)) = 1 ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end _ tempsMark. ["Beginning at right temp marker..." start _ end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isAlphaNumeric not & (str at: end+1) isAlphaNumeric not]]] whileFalse: ["Search left for the unused temp" end _ requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start _ start-1]. requestor correctFrom: start to: end with: ''. str _ str copyReplaceFrom: start to: end with: ''. madeChanges _ true. tempsMark _ tempsMark - (end-start+1)]] ifFalse: [self inform: 'You''ll first have to remove the statement where it''s stored into']]]. madeChanges ifTrue: [ParserRemovedUnusedTemps signal]! ! !Parser methodsFor: 'primitives' stamp: 'md 11/14/2003 16:53'! externalFunctionDeclaration "Parse the function declaration for a call to an external library." | descriptorClass callType retType externalName args argType module fn | descriptorClass _ Smalltalk at: #ExternalFunction ifAbsent:[nil]. descriptorClass == nil ifTrue:[^0]. callType _ descriptorClass callingConventionFor: here. callType == nil ifTrue:[^0]. "Parse return type" self advance. retType _ self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName _ here. (self match: #string) ifTrue:[externalName _ externalName asSymbol] ifFalse:[(self match:#number) ifFalse:[^self expected:'function name or index']]. (self matchToken:'(' asSymbol) ifFalse:[^self expected:'argument list']. args _ WriteStream on: Array new. [here == #')'] whileFalse:[ argType _ self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]. ]. (self matchToken:')' asSymbol) ifFalse:[^self expected:')']. (self matchToken: 'module:') ifTrue:[ module _ here. (self match: #string) ifFalse:[^self expected: 'String']. module _ module asSymbol]. Smalltalk at: #ExternalLibraryFunction ifPresent:[:xfn| fn _ xfn name: externalName module: module callType: callType returnType: retType argumentTypes: args contents. self allocateLiteral: fn. ]. ^120! ! !PartsBin methodsFor: 'dropping/grabbing' stamp: 'nk 8/6/2004 11:31'! morphToDropFrom: aMorph "Answer the morph to drop if the user attempts to drop aMorph" | aButton | aButton _ IconicButton new. aButton color: self color; initializeToShow: aMorph withLabel: aMorph externalName andSend: #veryDeepCopy to: aMorph veryDeepCopy. ^ aButton! ! !PartsBin methodsFor: 'dropping/grabbing' stamp: 'sw 6/13/2001 17:47'! wantsDroppedMorph: aMorph event: evt "Answer whether the receiver would like to accept the given morph. For a Parts bin, we accept just about anything except something that just originated from ourselves" (aMorph hasProperty: #beFullyVisibleAfterDrop) ifTrue: ["Sign that this was launched from a parts bun, probably indeed this very parts bin" ^ false]. ^ super wantsDroppedMorph: aMorph event: evt! ! !PartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 17:28'! listDirection: aListDirection quadList: quadList "Initialize the receiver to run horizontally or vertically, obtaining its elements from the list of tuples of the form: (<receiver> <selector> <label> <balloonHelp>)" | aButton aClass | self layoutPolicy: TableLayout new. self listDirection: aListDirection. self wrapCentering: #topLeft. self layoutInset: 2. self cellPositioning: #bottomCenter. aListDirection == #leftToRight ifTrue: [self vResizing: #rigid. self hResizing: #spaceFill. self wrapDirection: #topToBottom] ifFalse: [self hResizing: #rigid. self vResizing: #spaceFill. self wrapDirection: #leftToRight]. quadList do: [:tuple | aClass _ Smalltalk at: tuple first. aButton _ IconicButton new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass. (tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue: [aButton setBalloonText: tuple fourth]. self addMorphBack: aButton]! ! !PartsBin methodsFor: 'initialization' stamp: 'nk 9/1/2004 20:09'! listDirection: aListDirection quadList: quadList buttonClass: buttonClass "Initialize the receiver to run horizontally or vertically, obtaining its elements from the list of tuples of the form: (<receiver> <selector> <label> <balloonHelp>)" | aButton aClass | self layoutPolicy: TableLayout new. self listDirection: aListDirection. self wrapCentering: #topLeft. self layoutInset: 2. self cellPositioning: #bottomCenter. aListDirection == #leftToRight ifTrue: [self vResizing: #rigid. self hResizing: #spaceFill. self wrapDirection: #topToBottom] ifFalse: [self hResizing: #rigid. self vResizing: #spaceFill. self wrapDirection: #leftToRight]. quadList do: [:tuple | aClass _ Smalltalk at: tuple first. aButton _ buttonClass new initializeWithThumbnail: (self class thumbnailForQuad: tuple color: self color) withLabel: tuple third andColor: self color andSend: tuple second to: aClass. (tuple size > 3 and: [tuple fourth isEmptyOrNil not]) ifTrue: [aButton setBalloonText: tuple fourth]. self addMorphBack: aButton]! ! !PartsBin methodsFor: 'properties' stamp: 'dgd 8/30/2003 15:52'! innocuousName "Answer a harmless name for an unnamed instance" ^ 'parts bin' translated! ! !PartsBin class methodsFor: 'class initialization' stamp: 'sw 7/12/2001 19:07'! initialize "Initialize the PartsBin class, by starting it out with an empty Thumbnails dictionary" Thumbnails _ Dictionary new "PartsBin initialize"! ! !PartsBin class methodsFor: 'instance creation' stamp: 'nk 8/31/2004 18:51'! newPartsBinWithOrientation: aListDirection andColor: aColor from: quadList "Answer a new PartBin object, to run horizontally or vertically, obtaining its elements from the list of tuples of the form: (<receiver> <selector> <label> <balloonHelp>)" ^ (self new) color: aColor; listDirection: aListDirection quadList: (self translatedQuads: quadList).! ! !PartsBin class methodsFor: 'instance creation' stamp: 'dgd 8/26/2004 12:24'! newPartsBinWithOrientation: aListDirection from: quadList "Answer a new PartBin object, to run horizontally or vertically, obtaining its elements from the list of tuples of the form: (<receiver> <selector> <label> <balloonHelp>)" ^ self new listDirection: aListDirection quadList: (self translatedQuads: quadList) ! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 8/12/2001 17:44'! cacheAllThumbnails "In one monster operation, cache all the thumbnails of parts. Intended to be called from do-its in update postscripts, for example, or manually." Cursor wait showWhile: [Morph withAllSubclasses do: [:aClass | (aClass class includesSelector: #descriptionForPartsBin) ifTrue: [self thumbnailForPartsDescription: aClass descriptionForPartsBin]. (aClass class includesSelector: #supplementaryPartsDescriptions) ifTrue: [aClass supplementaryPartsDescriptions do: [:aDescription | self thumbnailForPartsDescription: aDescription]]]] "Time millisecondsToRun: [PartsBin initialize. PartsBin cacheAllThumbnails]" ! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 19:06'! cacheThumbnail: aThumbnail forSymbol: aSymbol "Cache the thumbnail provided as the graphic representing a parts-bin denizen whose name is the given symbol" Thumbnails at: aSymbol put: aThumbnail! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 18:56'! clearThumbnailCache "Clear the cache of thumbnails: PartsBin clearThumbnailCache " Thumbnails _ Dictionary new! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 7/12/2001 19:06'! thumbnailForInstanceOf: aMorphClass "Answer a thumbnail for a stand-alone instance of the given class, creating it if necessary. If it is created afresh, it will also be cached at this time" | aThumbnail | ^ Thumbnails at: aMorphClass name ifAbsent: [aThumbnail _ Thumbnail new makeThumbnailFromForm: aMorphClass newStandAlone imageForm. self cacheThumbnail: aThumbnail forSymbol: aMorphClass name. ^ aThumbnail] "PartsBin initialize"! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'sw 10/24/2001 15:29'! thumbnailForPartsDescription: aPartsDescription "Answer a thumbnail for the given parts description creating it if necessary. If it is created afresh, it will also be cached at this time" | aThumbnail aSymbol | aSymbol _ aPartsDescription formalName asSymbol. ^ Thumbnails at: aSymbol ifAbsent: [aThumbnail _ Thumbnail new makeThumbnailFromForm: aPartsDescription sampleImageForm. self cacheThumbnail: aThumbnail forSymbol: aSymbol. ^ aThumbnail] "PartsBin initialize"! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'nk 9/1/2004 17:38'! thumbnailForQuad: aQuint "Answer a thumbnail for a morph obtaining as per the quintuplet provided, creating the thumbnail if necessary. If it is created afresh, it will also be cached at this time" ^self thumbnailForQuad: aQuint color: Color transparent.! ! !PartsBin class methodsFor: 'thumbnail cache' stamp: 'nk 9/1/2004 17:44'! thumbnailForQuad: aQuint color: aColor "Answer a thumbnail for a morph obtaining as per the quintuplet provided, creating the thumbnail if necessary. If it is created afresh, it will also be cached at this time" | aThumbnail aSymbol formToThumbnail labeledItem | aSymbol _ aQuint third. Thumbnails at: aSymbol ifPresent: [ :thumb | ^thumb ]. formToThumbnail _ aQuint at: 5 ifAbsent: []. formToThumbnail ifNil: [ labeledItem := (Smalltalk at: aQuint first) perform: aQuint second. formToThumbnail := labeledItem imageForm: 32 backgroundColor: aColor forRectangle: labeledItem fullBounds. formToThumbnail replaceColor: aColor withColor: Color transparent. ]. aThumbnail _ Thumbnail new makeThumbnailFromForm: formToThumbnail. self cacheThumbnail: aThumbnail forSymbol: aSymbol. ^ aThumbnail "PartsBin initialize"! ! !PartsBin class methodsFor: 'private' stamp: 'dgd 8/26/2004 12:23'! translatedQuads: quads "private - convert the given quads to a translated one" | translatedQuads | translatedQuads := quads collect: [:each | | element | element := each copy. element at: 3 put: each third translated. element at: 4 put: each fourth translated. element. ]. ^ translatedQuads ! ! !PartsWindow methodsFor: 'as yet unclassified' stamp: 'sw 8/12/2001 17:16'! saveAsCustomPartsBin self inform: 'this feature is obsolete, as, indeed, is this entire tool'! ! !PartsWindow methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !PartsWindow methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:46'! initialize "initialize the state of the receiver" | aFont aForm | super initialize. "" openForEditing _ false. aFont _ Preferences standardButtonFont. self addMorph: (prevButton _ SimpleButtonMorph new borderWidth: 0; label: '<' font: aFont; color: Color transparent; setBalloonText: 'previous page'; actionSelector: #previousPage; target: self; extent: 16 @ 16). self addMorph: (nextButton _ SimpleButtonMorph new borderWidth: 0; label: '>' font: aFont; color: Color transparent; setBalloonText: 'next page'; actionSelector: #nextPage; target: self; extent: 16 @ 16). menuButton _ ThreePhaseButtonMorph new onImage: (aForm _ ScriptingSystem formAtKey: 'OfferToUnlock'); offImage: (ScriptingSystem formAtKey: 'OfferToLock'); pressedImage: (ScriptingSystem formAtKey: 'OfferToLock'); extent: aForm extent; state: #on. menuButton target: self; actionSelector: #toggleStatus; actWhen: #buttonUp. menuButton setBalloonText: 'open for editing'. self addMorph: menuButton. " self addMorph: (menuButton _ SimpleButtonMorph new borderWidth: 0; label: '·' font: aFont; color: Color transparent; actWhen: #buttonDown; actionSelector: #invokePartsWindowMenu; target: self; extent: 16@16)." self adjustBookControls! ! !PartsWindow methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'parts window controls...' translated action: #invokePartsWindowMenu ! ! !PartsWindow methodsFor: 'resize/collapse' stamp: 'sw 6/5/2001 00:19'! wantsExpandBox "Answer whether I'd like an expand box" ^ false! ! !PartsWindow commentStamp: '<historical>' prior: 0! Disused. Instances may persist in users' images, so this obsolete code is kept around for the time being. Supplanted by the ObjectsTool.! !Password methodsFor: 'as yet unclassified' stamp: 'tk 10/15/2002 14:39'! serverPasswords "Get the server passwords off the disk and decode them. The file 'sqk.info' must be in some folder that Squeak thinks is special (vm folder, or default directory). (Note: This code works even if you are running with no system sources file.)" | sfile | (sfile _ FileDirectory lookInUsualPlaces: 'sqk.info') ifNil: [^ nil]. "If not there, Caller will ask user for password" "If you don't have this file, and you really do want to release an update, contact Ted Kaehler." ^ (self decode: (sfile contentsOfEntireFile)) findTokens: String cr ! ! !Password methodsFor: 'accessing' stamp: 'dgd 12/27/2003 10:50'! passwordFor: serverDir "Returned the password from one of many sources. OK if send in a nil arg." | sp msg | cache ifNotNil: [^ cache]. sequence ifNotNil: [ (sp _ self serverPasswords) ifNotNil: [ sequence <= sp size ifTrue: [^ sp at: sequence]]]. msg _ serverDir isRemoteDirectory ifTrue: [serverDir moniker] ifFalse: ['this directory']. (serverDir user = 'anonymous') & (serverDir typeWithDefault == #ftp) ifTrue: [ ^ cache _ FillInTheBlank request: 'Please let this anonymous ftp\server know your email address.\This is the polite thing to do.' withCRs initialAnswer: 'yourName@company.com']. ^ cache _ FillInTheBlank requestPassword: 'Password for ', serverDir user, ' at ', msg, ':'. "Diff between empty string and abort?"! ! !Password methodsFor: 'accessing' stamp: 'mir 6/29/2001 01:01'! sequence ^sequence! ! !PasteUpMorph methodsFor: 'Nebraska' stamp: 'wiz 1/9/2005 15:37'! isSafeToServe "True if all conditions are met to share safely. (attends to mantis bug #0000519). Right now we reject worlds with FlashMorphs for subMorphs." (self findA: FlashMorph) ifNil: [^true]. self inform: 'Can not share world if Squeaklogo is present. Collapse logo and try again'. ^false! ! !PasteUpMorph methodsFor: 'WiW support' stamp: 'dgd 8/31/2004 16:25'! addMorphInLayer: aMorph super addMorphInLayer: aMorph. aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'ar 6/30/2001 13:21'! assureFlapWidth: requestedWidth | tab | self width: requestedWidth. tab _ self flapTab ifNil:[^self]. tab flapShowing ifTrue:[tab hideFlap; showFlap].! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'tk 7/17/2001 16:07'! flapTab | ww | self isFlap ifFalse:[^nil]. ww _ self world ifNil: [World]. ^ww flapTabs detect:[:any| any referent == self] ifNone:[nil]! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'ar 4/25/2001 17:15'! useRoundedCorners "Somewhat special cased because we do have to fill Display for this" super useRoundedCorners. self == World ifTrue:[Display bits primFill: 0]. "done so that we *don't* get a flash"! ! !PasteUpMorph methodsFor: 'caching' stamp: 'ar 2/21/2001 17:39'! releaseCachedState super releaseCachedState. presenter ifNotNil:[presenter flushPlayerListCache]. self isWorldMorph ifTrue:[self cleanseStepList].! ! !PasteUpMorph methodsFor: 'change reporting' stamp: 'ar 1/5/2002 17:06'! invalidRect: damageRect from: aMorph "Clip damage reports to my bounds, since drawing is clipped to my bounds." self == self outermostWorldMorph ifTrue: [worldState recordDamagedRect: (damageRect intersect: self bounds)] ifFalse: [super invalidRect: damageRect from: aMorph] ! ! !PasteUpMorph methodsFor: 'copying' stamp: 'tk 7/30/2001 09:26'! veryDeepCopyWith: deepCopier "See storeDataOn:" ^ self isWorldMorph ifTrue: [self] "never copy the World" ifFalse: [super veryDeepCopyWith: deepCopier]! ! !PasteUpMorph methodsFor: 'cursor' stamp: 'tak 11/7/2004 18:33'! cursorWrapped: aNumber "Set the cursor to the given number, modulo the number of items I contain. Fractional cursor values are allowed." | oldRect newRect offset | cursor = aNumber ifTrue: [^ self]. self hasSubmorphs ifFalse: [cursor := 1. ^ self]. oldRect := self selectedRect. offset := (self asNumber: aNumber) - 1 \\ submorphs size. cursor := offset + 1. newRect := self selectedRect. self indicateCursor ifTrue: [self invalidRect: oldRect; invalidRect: newRect]! ! !PasteUpMorph methodsFor: 'cursor' stamp: 'jdl 3/28/2003 08:17'! selectedRect "Return a rectangle enclosing the morph at the current cursor. Note that the cursor may be a float and may be out of range, so pick the nearest morph. Assume there is at least one submorph." | p | p := cursor asInteger. p := p min: submorphs size. p := p max: 1. ^(submorphs at: p) fullBounds expandBy: 2! ! !PasteUpMorph methodsFor: 'cursor' stamp: 'bf 9/30/2002 23:37'! valueAtCursor "Answer the submorph of mine indexed by the value of my 'cursor' slot" submorphs isEmpty ifTrue: [^ self presenter standardPlayer costume]. ^ (submorphs at: ((cursor truncated max: 1) min: submorphs size)) morphRepresented! ! !PasteUpMorph methodsFor: 'display' stamp: 'ar 9/7/2002 15:24'! gradientFillColor: aColor "For backwards compatibility with GradientFillMorph" self flag: #fixThis. self useGradientFill. self fillStyle colorRamp: {0.0 -> self fillStyle colorRamp first value. 1.0 -> aColor}. self changed! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'nk 7/4/2003 16:07'! drawOn: aCanvas "Draw in order: - background color - grid, if any - background sketch, if any - Update and draw the turtleTrails form. See the comment in updateTrailsForm. - cursor box if any Later (in drawSubmorphsOn:) I will skip drawing the background sketch." "draw background fill" super drawOn: aCanvas. "draw grid" (self griddingOn and: [self gridVisible]) ifTrue: [aCanvas fillRectangle: self bounds fillStyle: (self gridFormOrigin: self gridOrigin grid: self gridModulus background: nil line: Color lightGray)]. "draw background sketch." backgroundMorph ifNotNil: [ self clipSubmorphs ifTrue: [ aCanvas clipBy: self clippingBounds during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]] ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]]. "draw turtle trails" self updateTrailsForm. turtleTrailsForm ifNotNil: [aCanvas paintImage: turtleTrailsForm at: self position]. "draw cursor" (submorphs notEmpty and: [self indicateCursor]) ifTrue: [aCanvas frameRectangle: self selectedRect width: 2 color: Color black]! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'nb 6/17/2003 12:25'! acceptDroppingMorph: dropped event: evt "The supplied morph, known to be acceptable to the receiver, is now to be assimilated; the precipitating event is supplied" | mm tfm aMorph | aMorph _ self morphToDropFrom: dropped. self isWorldMorph ifTrue:["Add the given morph to this world and start stepping it if it wants to be." self addMorphFront: aMorph. (aMorph fullBounds intersects: self viewBox) ifFalse: [Beeper beep. aMorph position: self bounds center]] ifFalse:[super acceptDroppingMorph: aMorph event: evt]. aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]]. aMorph allMorphsDo: "Establish any penDown morphs in new world" [:m | m player ifNotNil: [m player getPenDown ifTrue: [((mm _ m player costume) notNil and: [(tfm _ mm owner transformFrom: self) notNil]) ifTrue: [self noteNewLocation: (tfm localPointToGlobal: mm referencePosition) forPlayer: m player]]]]. self isPartsBin ifTrue: [aMorph isPartsDonor: true. aMorph stopSteppingSelfAndSubmorphs. aMorph suspendEventHandler] ifFalse: [self world startSteppingSubmorphsOf: aMorph]. self presenter morph: aMorph droppedIntoPasteUpMorph: self. self showingListView ifTrue: [self sortSubmorphsBy: (self valueOfProperty: #sortOrder). self currentWorld abandonAllHalos]! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/4/2001 00:54'! dropEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^ (self valueOfProperty: #dropEnabled) ~~ false ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'gm 2/22/2003 13:08'! morphToDropFrom: aMorph "Given a morph being carried by the hand, which the hand is about to drop, answer the actual morph to be deposited. Normally this would be just the morph itself, but several unusual cases arise, which this method is designed to service." | aNail representee handy posBlock tempPos | handy := self primaryHand. posBlock := [:z | tempPos := handy position - ((handy targetOffset - aMorph formerPosition) * (z extent / aMorph extent)) rounded. self pointFromWorld: tempPos]. self alwaysShowThumbnail ifTrue: [aNail := aMorph representativeNoTallerThan: self maxHeightToAvoidThumbnailing norWiderThan: self maximumThumbnailWidth thumbnailHeight: self heightForThumbnails. aNail == aMorph ifFalse: [aMorph formerPosition: aMorph position. aNail position: (posBlock value: aNail)]. ^aNail]. ((aMorph isKindOf: MorphThumbnail) and: [(representee := aMorph morphRepresented) owner isNil]) ifTrue: [representee position: (posBlock value: representee). ^representee]. self showingListView ifTrue: [^aMorph listViewLineForFieldList: (self valueOfProperty: #fieldListSelectors)]. (aMorph hasProperty: #newPermanentScript) ifTrue: [^aMorph asEmptyPermanentScriptor]. ((aMorph isKindOf: PhraseTileMorph) or: [aMorph isSyntaxMorph]) ifFalse: [^aMorph]. aMorph userScriptSelector isEmptyOrNil ifTrue: ["non-user" self automaticPhraseExpansion ifFalse: [^aMorph]]. ^aMorph morphToDropInPasteUp: self! ! !PasteUpMorph methodsFor: 'e-toy support' stamp: 'nk 10/13/2004 11:26'! lastKeystroke "Answer the last keystroke fielded by the receiver" ^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! ! !PasteUpMorph methodsFor: 'e-toy support' stamp: 'nk 10/13/2004 11:27'! lastKeystroke: aString "Remember the last keystroke fielded by the receiver" ^ self setProperty: #lastKeystroke toValue: aString! ! !PasteUpMorph methodsFor: 'e-toy support' stamp: 'nk 9/8/2003 17:17'! referencePlayfield "Answer a pasteup morph to be used as the reference for cartesian coordinates. Do not get fooled by other morphs (like viewers) that happen to be named 'playfield'." ^self isWorldMorph ifTrue: [ self submorphThat: [ :s | (s knownName = 'playfield') and: [ s isPlayfieldLike] ] ifNone: [self]] ifFalse: [ super referencePlayfield ]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'mir 1/10/2002 17:35'! dropFiles: anEvent "Handle a number of dropped files from the OS. TODO: - use a more general mechanism for figuring out what to do with the file (perhaps even offering a choice from a menu) - remember the resource location or (when in browser) even the actual file handle " | numFiles stream handler | numFiles _ anEvent contents. 1 to: numFiles do: [:i | stream _ FileStream requestDropStream: i. handler _ ExternalDropHandler lookupExternalDropHandler: stream. [handler ifNotNil: [handler handle: stream in: self dropEvent: anEvent]] ensure: [stream close]].! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 8/28/2004 18:44'! handlesKeyboard: evt ^self isWorldMorph or:[evt keyCharacter == Character tab and:[self tabAmongFields]]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/10/2000 14:12'! keyStroke: anEvent "A keystroke has been made. Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:" super keyStroke: anEvent. "Give event handlers a chance" (anEvent keyCharacter == Character tab) ifTrue: [(self hasProperty: #tabAmongFields) ifTrue:[^ self tabHitWithEvent: anEvent]]. self isWorldMorph ifTrue: [self keystrokeInWorld: anEvent]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 2/23/2001 16:44'! morphToGrab: event "Return the morph to grab from a mouse down event. If none, return nil." self submorphsDo:[:m| ((m rejectsEvent: event) not and:[m fullContainsPoint: event cursorPoint]) ifTrue:[^m]. ]. ^nil! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'dgd 9/11/2004 20:56'! mouseDown: evt "Handle a mouse down event." | grabbedMorph handHadHalos | grabbedMorph _ self morphToGrab: evt. grabbedMorph ifNotNil:[ grabbedMorph isSticky ifTrue:[^self]. self isPartsBin ifFalse:[^evt hand grabMorph: grabbedMorph]. grabbedMorph _ grabbedMorph partRepresented duplicate. grabbedMorph restoreSuspendedEventHandler. (grabbedMorph fullBounds containsPoint: evt position) ifFalse:[grabbedMorph position: evt position]. "Note: grabbedMorph is ownerless after duplicate so use #grabMorph:from: instead" ^ evt hand grabMorph: grabbedMorph from: self]. (super handlesMouseDown: evt) ifTrue:[^super mouseDown: evt]. handHadHalos _ evt hand halo notNil. evt hand removeHalo. "shake off halos" evt hand releaseKeyboardFocus. "shake of keyboard foci" (evt shiftPressed not and:[ self isWorldMorph not ] and:[ Preferences easySelection not ]) ifTrue:[ "explicitly ignore the event if we're not the world and we'll not select, so that we could be picked up if need be" evt wasHandled: false. ^ self. ]. ( evt shiftPressed or: [ Preferences easySelection ] ) ifTrue:[ "We'll select on drag, let's decide what to do on click" | clickSelector | clickSelector := nil. evt shiftPressed ifTrue:[ clickSelector := #findWindow:. ] ifFalse:[ self isWorldMorph ifTrue:[ clickSelector := handHadHalos ifTrue: [ #delayedInvokeWorldMenu: ] ifFalse: [ #invokeWorldMenu: ] ] ]. evt hand waitForClicksOrDrag: self event: evt selectors: { clickSelector. nil. nil. #dragThroughOnDesktop: } threshold: 5. ] ifFalse:[ "We wont select, just bring world menu if I'm the world" self isWorldMorph ifTrue:[ handHadHalos ifTrue: [ self delayedInvokeWorldMenu: evt ] ifFalse: [ self invokeWorldMenu: evt ] ] ]. ! ! !PasteUpMorph methodsFor: 'events-processing' stamp: 'ar 4/5/2001 21:42'! processEvent: anEvent using: defaultDispatcher "Reimplemented to install the receiver as the new ActiveWorld if it is one" | priorWorld result | self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher]. priorWorld _ ActiveWorld. ActiveWorld _ self. result _ super processEvent: anEvent using: defaultDispatcher. ActiveWorld _ priorWorld. ^result! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/30/2001 20:31'! addGlobalFlaps "Must make global flaps adapt to world. Do this even if not shown, so the old world will not be pointed at by the flaps." | use thisWorld | use _ Flaps sharedFlapsAllowed. CurrentProjectRefactoring currentFlapsSuppressed ifTrue: [use _ false]. "Smalltalk isMorphic ifFalse: [use _ false]." thisWorld _ use ifTrue: [self] ifFalse: [PasteUpMorph new initForProject: "fake to be flap owner" WorldState new; bounds: (0@0 extent: 4000@4000); viewBox: (0@0 extent: 4000@4000)]. Flaps globalFlapTabsIfAny do: [:aFlapTab | (CurrentProjectRefactoring isFlapEnabled: aFlapTab) ifTrue: [(aFlapTab world == thisWorld) ifFalse: [thisWorld addMorphFront: aFlapTab. aFlapTab adaptToWorld: thisWorld]. "always do" use ifTrue: [aFlapTab spanWorld. aFlapTab adjustPositionAfterHidingFlap. aFlapTab flapShowing ifTrue: [aFlapTab showFlap]]]]! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'dgd 8/31/2004 16:27'! bringFlapTabsToFront self deprecated: 'Replaced by #bringTopmostsToFront'. (submorphs select:[:m| m wantsToBeTopmost]) do:[:m| self addMorphInLayer: m].! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'dgd 8/31/2004 16:25'! bringTopmostsToFront (submorphs select:[:m| m wantsToBeTopmost]) do:[:m| self addMorphInLayer: m].! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'dgd 8/31/2004 16:23'! deleteAllFlapArtifacts "self currentWorld deleteAllFlapArtifacts" self submorphs do:[:m | m wantsToBeTopmost ifTrue:[m delete]]! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'sw 5/5/2001 00:27'! deleteGlobalFlapArtifacts "Delete all flap-related detritus from the world" | localFlaps | localFlaps _ self localFlapTabs collect: [:m | m referent]. self submorphs do: [:m | ((m isFlapTab) and: [m isGlobalFlap]) ifTrue: [m delete]. m isFlap ifTrue:[(localFlaps includes: m) ifFalse: [m delete]]] "ActiveWorld deleteGlobalFlapArtifacts" ! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:23'! enableGlobalFlaps "Restore saved global flaps, or obtain brand-new system defaults if necessary" Flaps globalFlapTabs. "If nil, creates new ones" self addGlobalFlaps "put them on screen"! ! !PasteUpMorph methodsFor: 'flaps' stamp: 'sw 4/17/2001 11:22'! localFlapTabs "Answer a list of local flap tabs in the current project" | globalList aList aFlapTab | globalList _ Flaps globalFlapTabsIfAny. aList _ OrderedCollection new. submorphs do: [:m | ((m isFlapTab) and: [(globalList includes: m) not]) ifTrue: [aList add: m] ifFalse: [((m isFlap) and: [(aFlapTab _ m submorphs detect: [:n | n isFlapTab] ifNone: [nil]) notNil]) ifTrue: [aList add: aFlapTab]]]. ^ aList! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! gridVisibleString "Answer a string to be used in a menu offering the opportunity to show or hide the grid" ^ (self gridVisible ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'show grid when gridding' translated! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'dgd 12/13/2003 19:30'! griddingString "Answer a string to use in a menu offering the user the opportunity to start or stop using gridding" ^ (self griddingOn ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'use gridding' translated! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'kfr 9/4/2004 15:44'! setGridSpec "Gridding rectangle provides origin and modulus" | response result | response _ FillInTheBlank request: 'New grid origin (usually 0@0):' translated initialAnswer: self gridOrigin printString. response isEmpty ifTrue: [^ self]. result _ [Compiler evaluate: response] ifError: [^ self]. (result isPoint and: [(result >= (0@0))]) ifTrue: [self gridOrigin: result] ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. response _ FillInTheBlank request: 'New grid spacing:' translated initialAnswer: self gridModulus printString. response isEmpty ifTrue: [^ self]. result _ [Compiler evaluate: response] ifError: [^ self]. (result isPoint and: [(result > (0@0)) ]) ifTrue: [self gridModulus: result] ifFalse: [self inform: ('Must be a Point with coordinates (for example 10@10)' translated )]. ! ! !PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'yo 2/17/2005 14:45'! wantsHaloFromClick (owner isSystemWindow) ifTrue: [^ false]. self paintBoxOrNil ifNotNil: [^ false]. ^ true. ! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'mir 10/29/2003 13:05'! becomeActiveDuring: aBlock "Make the receiver the ActiveWorld during the evaluation of aBlock. Note that this method does deliberately *not* use #ensure: to prevent re-installation of the world on project switches." | priorWorld priorHand priorEvent | priorWorld _ ActiveWorld. priorHand _ ActiveHand. priorEvent _ ActiveEvent. ActiveWorld _ self. ActiveHand _ self hands first. "default" ActiveEvent _ nil. "not in event cycle" [aBlock value] on: Error do: [:ex | ActiveWorld _ priorWorld. ActiveEvent _ priorEvent. ActiveHand _ priorHand. ex pass]! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 0.861 g: 1.0 b: 0.722! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 0.6! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:31'! initialize "initialize the state of the receiver" super initialize. "" cursor _ 1. padding _ 3. self enableDragNDrop. self isWorldMorph ifTrue: [self setProperty: #automaticPhraseExpansion toValue: true]. self clipSubmorphs: true! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'ar 3/3/2001 15:30'! newResourceLoaded "Some resource has just been loaded. Notify all morphs in case somebody wants to update accordingly." self allMorphsDo:[:m| m resourceJustLoaded ]. self fullRepaintNeeded.! ! !PasteUpMorph methodsFor: 'interaction loop' stamp: 'ls 5/6/2003 16:51'! doOneCycleNow "see the comment in doOneCycleNowFor:" worldState doOneCycleNowFor: self. ! ! !PasteUpMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:38'! currentVocabulary "Answer the default Vocabulary object to be applied when scripting" | aSym aVocab | aSym _ self valueOfProperty: #currentVocabularySymbol. aSym ifNil: [aVocab _ self valueOfProperty: #currentVocabulary. aVocab ifNotNil: [aSym _ aVocab vocabularyName. self setProperty: #currentVocabularySymbol toValue: aSym. self removeProperty: #currentVocabulary]]. ^ aSym ifNotNil: [Vocabulary vocabularyNamed: aSym] ifNil: [Vocabulary fullVocabulary]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: menu hand: aHandMorph "Add morph-specific menu itemns to the menu for the hand" super addCustomMenuItems: menu hand: aHandMorph. self addStackMenuItems: menu hand: aHandMorph. self addPenMenuItems: menu hand: aHandMorph. self addPlayfieldMenuItems: menu hand: aHandMorph. self isWorldMorph ifTrue: [(owner isKindOf: BOBTransformationMorph) ifTrue: [self addScalingMenuItems: menu hand: aHandMorph]. Flaps sharedFlapsAllowed ifTrue: [menu addUpdating: #suppressFlapsString target: CurrentProjectRefactoring action: #currentToggleFlapsSuppressed]. menu add: 'desktop menu...' translated target: self action: #putUpDesktopMenu:]. menu addLine! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:14'! addPenMenuItems: menu hand: aHandMorph "Add a pen-trails-within submenu to the given menu" menu add: 'penTrails within...' translated target: self action: #putUpPenTrailsSubmenu! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:15'! addPenTrailsMenuItemsTo: aMenu "Add items relating to pen trails to aMenu" | oldTarget | oldTarget _ aMenu defaultTarget. aMenu defaultTarget: self. aMenu add: 'clear pen trails' translated action: #clearTurtleTrails. aMenu addLine. aMenu add: 'all pens up' translated action: #liftAllPens. aMenu add: 'all pens down' translated action: #lowerAllPens. aMenu addLine. aMenu add: 'all pens show lines' translated action: #linesForAllPens. aMenu add: 'all pens show arrowheads' translated action: #arrowsForAllPens. aMenu add: 'all pens show arrows' translated action: #linesAndArrowsForAllPens. aMenu add: 'all pens show dots' translated action: #dotsForAllPens. aMenu defaultTarget: oldTarget! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 17:52'! addPlayfieldMenuItems: menu hand: aHandMorph "Add playfield-related items to the menu" menu add: 'playfield options...' translated target: self action: #presentPlayfieldMenu. (self hasProperty: #donorTextMorph) ifTrue: [menu add: 'send contents back to donor' translated action: #sendTextContentsBackToDonor]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 21:18'! addScalingMenuItems: menu hand: aHandMorph | subMenu | (subMenu _ MenuMorph new) defaultTarget: self; add: 'show application view' translated action: #showApplicationView; add: 'show factory view' translated action: #showFactoryView; add: 'show whole world view' translated action: #showFullView; add: 'expand' translated action: #showExpandedView; add: 'reduce' translated action: #showReducedView; addLine; add: 'define application view' translated action: #defineApplicationView; add: 'define factory view' translated action: #defineFactoryView. menu add: 'world scale and clip...' translated subMenu: subMenu! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'nk 2/15/2004 08:19'! addWorldHaloMenuItemsTo: aMenu hand: aHandMorph "Add standard halo items to the menu, given that the receiver is a World" | unlockables | self addFillStyleMenuItems: aMenu hand: aHandMorph. self addLayoutMenuItems: aMenu hand: aHandMorph. aMenu addLine. self addWorldToggleItemsToHaloMenu: aMenu. aMenu addLine. self addCopyItemsTo: aMenu. self addPlayerItemsTo: aMenu. self addExportMenuItems: aMenu hand: aHandMorph. self addStackItemsTo: aMenu. self addMiscExtrasTo: aMenu. Preferences noviceMode ifFalse: [self addDebuggingItemsTo: aMenu hand: aHandMorph]. aMenu addLine. aMenu defaultTarget: self. aMenu addLine. unlockables _ self submorphs select: [:m | m isLocked]. unlockables size == 1 ifTrue: [aMenu add: ('unlock "{1}"' translated format:{unlockables first externalName})action: #unlockContents]. unlockables size > 1 ifTrue: [aMenu add: 'unlock all contents' translated action: #unlockContents. aMenu add: 'unlock...' translated action: #unlockOneSubpart]. aMenu defaultTarget: aHandMorph. ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/20/2002 01:38'! addWorldToggleItemsToHaloMenu: aMenu "Add toggle items for the world to the halo menu" #( (hasDragAndDropEnabledString changeDragAndDrop 'whether I am open to having objects dropped into me') (roundedCornersString toggleCornerRounding 'whether the world should have rounded corners')) do: [:trip | aMenu addUpdating: trip first action: trip second. aMenu balloonTextForLastItem: trip third]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:59'! autoExpansionString "Answer the string to be shown in a menu to represent the auto-phrase-expansion status" ^ ((self hasProperty: #automaticPhraseExpansion) ifTrue: ['<on>'] ifFalse: ['<off>']) , 'auto-phrase-expansion' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:54'! autoLineLayoutString "Answer the string to be shown in a menu to represent the auto-line-layout status" ^ (self autoLineLayout ifTrue: ['<on>'] ifFalse: ['<off>']) , 'auto-line-layout' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:02'! autoViewingString "Answer the string to be shown in a menu to represent the automatic-viewing status" ^ (self automaticViewing ifTrue: ['<on>'] ifFalse: ['<off>']) , 'automatic viewing' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:01'! batchPenTrailsString "Answer the string to be shown in a menu to represent the batch-pen-trails enabled status" ^ (self batchPenTrails ifTrue: ['<on>'] ifFalse: ['<off>']), 'batch pen trails' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 8/30/2003 20:42'! buildDebugMenu: aHandMorph | aMenu | aMenu _ super buildDebugMenu: aHandMorph. aMenu add: 'abandon costume history' translated target: self action: #abandonCostumeHistory. ^ aMenu! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:01'! fenceEnabledString "Answer the string to be shown in a menu to represent the fence enabled status" ^ (self fenceEnabled ifTrue: ['<on>'] ifFalse: ['<off>']) , 'fence enabled' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:56'! indicateCursorString "Answer the string to be shown in a menu to represent the whether-to-indicate-cursor status" ^ (self indicateCursor ifTrue: ['<on>'] ifFalse: ['<off>']) , 'indicate cursor' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'! isOpenForDragNDropString "Answer the string to be shown in a menu to represent the open-to-drag-n-drop status" ^ (self dragNDropEnabled ifTrue: ['<on>'] ifFalse: ['<off>']) , 'open to drag & drop' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:57'! isPartsBinString "Answer the string to be shown in a menu to represent the parts-bin status" ^ (self isPartsBin ifTrue: ['<on>'] ifFalse: ['<off>']), 'parts bin' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 17:58'! mouseOverHalosString "Answer the string to be shown in a menu to represent the mouse-over-halos status" ^ (self wantsMouseOverHalos ifTrue: ['<on>'] ifFalse: ['<off>']) , 'mouse-over halos' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'! originAtCenterString "Answer the string to be shown in a menu to represent the origin-at-center status" ^ ((self hasProperty: #originAtCenter) ifTrue: ['<on>'] ifFalse: ['<off>']), 'origin-at-center' translated! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'yo 2/10/2005 17:40'! playfieldOptionsMenu "Answer an auxiliary menu with options specific to playfields -- too many to be housed in the main menu" | aMenu isWorld | isWorld _ self isWorldMorph. aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. aMenu add: 'save on file...' translated action: #saveOnFile. aMenu add: 'save as SqueakPage at url...' translated action: #saveOnURL. aMenu add: 'update all from resources' translated action: #updateAllFromResources. (self valueOfProperty: #classAndMethod) ifNotNil: [aMenu add: 'broadcast as documentation' translated action: #saveDocPane]. aMenu add: 'round up strays' translated action: #roundUpStrays. aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated. aMenu add: 'show all players' translated action: #showAllPlayers. aMenu balloonTextForLastItem: 'Make visible the viewers for all players which have user-written scripts in this playfield.' translated. aMenu add: 'hide all players' translated action: #hideAllPlayers. aMenu balloonTextForLastItem: 'Make invisible the viewers for all players in this playfield. This will save space before you publish this project' translated. aMenu addLine. aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs. aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated. self griddingOn ifTrue: [aMenu add: 'turn gridding off' translated action: #griddingOnOff. aMenu add: (self gridVisible ifTrue: ['hide'] ifFalse: ['show']) translated, ' grid' translated action: #gridVisibleOnOff. aMenu add: 'set grid spacing...' translated action: #setGridSpec] ifFalse: [aMenu add: 'turn gridding on' translated action: #griddingOnOff]. aMenu addLine. #( (autoLineLayoutString toggleAutoLineLayout 'whether submorphs should automatically be laid out in lines') (indicateCursorString toggleIndicateCursor 'whether the "current" submorph should be indicated with a dark black border') (isPartsBinString toggleIsPartsBin 'whether dragging an object from the interior should produce a COPY of the object') (isOpenForDragNDropString toggleDragNDrop 'whether objects can be dropped into and dragged out of me') (mouseOverHalosString toggleMouseOverHalos 'whether objects should put up halos when the mouse is over them') (autoExpansionString toggleAutomaticPhraseExpansion 'whether tile phrases, dropped on me, should automatically sprout Scriptors around them') (originAtCenterString toggleOriginAtCenter 'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield') (showThumbnailString toggleAlwaysShowThumbnail 'whether large objects should be represented by thumbnail miniatures of themselves') (fenceEnabledString toggleFenceEnabled 'whether moving objects should stop at the edge of their container') (batchPenTrailsString toggleBatchPenTrails 'if true, detailed movement of pens between display updates is ignored. Thus multiple line segments drawn within a script may not be seen individually.') ) do: [:triplet | (isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail) includes: triplet second]) ifFalse: [aMenu addUpdating: triplet first action: triplet second. aMenu balloonTextForLastItem: triplet third translated]]. aMenu addUpdating: #autoViewingString action: #toggleAutomaticViewing. aMenu balloonTextForLastItem: 'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.' translated. ((isWorld not or: [self backgroundSketch notNil]) or: [presenter isNil]) ifTrue: [aMenu addLine]. isWorld ifFalse: [aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight. aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated. aMenu add: 'behave like a Holder' translated action: #becomeLikeAHolder. aMenu balloonTextForLastItem: 'Set properties to make this object nicely set up to hold frames of a scripted animation.' translated]. self backgroundSketch ifNotNil: [aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting. aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated]. presenter ifNil: [aMenu add: 'make detachable' translated action: #makeDetachable. aMenu balloonTextForLastItem: 'Allow this area to be separately governed by its own controls.' translated]. aMenu addLine. aMenu add: 'use standard texture' translated action: #setStandardTexture. aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated. aMenu add: 'make graph paper...' translated action: #makeGraphPaper. aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated. aMenu addTitle: 'playfield options...' translated. ^ aMenu ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:04'! presentViewMenu "Answer an auxiliary menu with options specific to viewing playfields -- this is put up from the provisional 'view' halo handle, on pasteup morphs only." | aMenu isWorld | isWorld _ self isWorldMorph. aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. self addViewingItemsTo: aMenu. #( "(autoLineLayoutString toggleAutoLineLayout 'whether submorphs should automatically be laid out in lines')" (indicateCursorString toggleIndicateCursor 'whether the "current" submorph should be indicated with a dark black border') (resizeToFitString toggleResizeToFit 'whether I should automatically strive exactly to fit my contents') (behaveLikeAHolderString toggleBehaveLikeAHolder 'whether auto-line-layout, resize-to-fit, and indicate-cursor should be set to true; useful for animation control, etc.') (isPartsBinString toggleIsPartsBin 'whether dragging an object from the interior should produce a COPY of the object') (isOpenForDragNDropString toggleDragNDrop 'whether objects can be dropped into and dragged out of me') (mouseOverHalosString toggleMouseOverHalos 'whether objects should put up halos when the mouse is over them') (autoExpansionString toggleAutomaticPhraseExpansion 'whether tile phrases, dropped on me, should automatically sprout Scriptors around them') (originAtCenterString toggleOriginAtCenter 'whether the cartesian origin of the playfield should be at its lower-left corner or at the center of the playfield') (showThumbnailString toggleAlwaysShowThumbnail 'whether large objects should be represented by thumbnail miniatures of themselves') (fenceEnabledString toggleFenceEnabled 'whether moving objects should stop at the edge of their container') (autoViewingString toggleAutomaticViewing 'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.') (griddingString griddingOnOff 'whether gridding should be used in my interior') (gridVisibleString gridVisibleOnOff 'whether the grid should be shown when gridding is on') ) do: [:triplet | (isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail toggleAutomaticViewing ) includes: triplet second]) ifFalse: [aMenu addUpdating: triplet first action: triplet second. aMenu balloonTextForLastItem: triplet third translated]]. aMenu addLine. aMenu add: 'round up strays' translated action: #roundUpStrays. aMenu balloonTextForLastItem: 'Bring back all objects whose current coordinates keep them from being visible, so that at least a portion of each of my interior objects can be seen.' translated. aMenu add: 'shuffle contents' translated action: #shuffleSubmorphs. aMenu balloonTextForLastItem: 'Rearranges my contents in random order' translated. aMenu add: 'set grid spacing...' translated action: #setGridSpec. aMenu balloonTextForLastItem: 'Set the spacing to be used when gridding is on' translated. isWorld ifFalse: [aMenu add: 'set thumbnail height...' translated action: #setThumbnailHeight. aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them' translated]. self backgroundSketch ifNotNil: [aMenu add: 'delete background painting' translated action: #deleteBackgroundPainting. aMenu balloonTextForLastItem: 'delete the graphic that forms the background for this me.' translated]. aMenu addLine. self addPenTrailsMenuItemsTo: aMenu. aMenu addLine. aMenu add: 'use standard texture' translated action: #setStandardTexture. aMenu balloonTextForLastItem: 'use a pale yellow-and-blue background texture here.' translated. aMenu add: 'make graph paper...' translated action: #makeGraphPaper. aMenu balloonTextForLastItem: 'Design your own graph paper and use it as the background texture here.' translated. aMenu addTitle: ('viewing options for "{1}"' translated format: {self externalName}). aMenu popUpForHand: self activeHand in: self world ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 3/3/2004 01:17'! putUpPenTrailsSubmenu "Put up the pen trails menu" | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu title: 'pen trails' translated. aMenu addStayUpItem. self addPenTrailsMenuItemsTo: aMenu. aMenu popUpInWorld: ActiveWorld! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 4/23/2001 12:33'! reformulateUpdatingMenus "Give any updating menu morphs in the receiver a fresh kiss of life" (self submorphs select: [:m | m isKindOf: UpdatingMenuMorph]) do: [:m | m updateMenu] "NB: to do the perfect job here one might well want to extend across allMorphs here, but the expense upon project entry is seemingly too high a price to pay at this point"! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 2/18/2003 03:08'! sendTextContentsBackToDonor "Send my string contents back to the Text Morph from whence I came" (self valueOfProperty: #donorTextMorph) ifNotNilDo: [:aDonor | aDonor setCharacters: self assuredPlayer getStringContents]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'dgd 9/6/2003 18:00'! showThumbnailString "Answer the string to be shown in a menu to represent the show-thumbnails status" ^ ((self hasProperty: #alwaysShowThumbnail) ifTrue: ['<on>'] ifFalse: ['<off>']), 'show thumbnails' translated! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/18/2001 18:36'! hideFlapsOtherThan: aFlapTab ifClingingTo: anEdgeSymbol "Hide flaps on the given edge unless they are the given one" self flapTabs do: [:aTab | (aTab edgeToAdhereTo == anEdgeSymbol) ifTrue: [aTab == aFlapTab ifFalse: [aTab hideFlap]]]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'ar 2/12/2001 23:17'! hideViewerFlaps self flapTabs do:[:aTab | (aTab isKindOf: ViewerFlapTab) ifTrue:[aTab hideFlap]]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'dgd 8/30/2003 15:52'! innocuousName ^ (self isFlap) ifTrue: ['flap' translated] ifFalse: [super innocuousName]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'yo 2/17/2005 16:58'! mouseX "Answer the x-coordinate of the mouse, in my coordinate system" ^ self isInWorld ifTrue: [((self pointFromWorld: self cursorPoint) x) - self cartesianOrigin x] ifFalse: [0]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'yo 2/17/2005 16:58'! mouseY "Answer the y-coordinate of the mouse, in my coordinate system" ^ self isInWorld ifTrue: [self cartesianOrigin y - ((self pointFromWorld: self cursorPoint) y)] ifFalse: [0]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/23/2003 03:46'! prepareToBeSaved "Prepare for export via the ReferenceStream mechanism" | exportDict soundKeyList players | super prepareToBeSaved. turtlePen _ nil. self isWorldMorph ifTrue: [soundKeyList _ Set new. (players _ self presenter allExtantPlayers) do: [:aPlayer | aPlayer slotInfo associationsDo: [:assoc | assoc value type == #Sound ifTrue: [soundKeyList add: (aPlayer instVarNamed: assoc key)]]]. players do: [:p | p allScriptEditors do: [:e | (e allMorphs select: [:m | m isKindOf: SoundTile]) do: [:aTile | soundKeyList add: aTile literal]]]. (self allMorphs select: [:m | m isKindOf: SoundTile]) do: [:aTile | soundKeyList add: aTile literal]. soundKeyList removeAllFoundIn: SampledSound universalSoundKeys. soundKeyList removeAllSuchThat: [:aKey | (SampledSound soundLibrary includesKey: aKey) not]. soundKeyList isEmpty ifFalse: [exportDict _ Dictionary new. soundKeyList do: [:aKey | exportDict add: (SampledSound soundLibrary associationAt: aKey)]. self setProperty: #soundAdditions toValue: exportDict]]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'dgd 8/31/2004 16:23'! roundUpStrays self submorphsDo: [:m | (m wantsToBeTopmost) ifFalse: [m goHome. m isPlayfieldLike ifTrue: [m roundUpStrays]]]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/22/2001 06:21'! viewerFlapTabFor: anObject "Open up a Viewer on aMorph in its own flap, creating it if necessary" | bottomMost aPlayer aFlapTab tempFlapTab | bottomMost _ self top. aPlayer _ anObject isMorph ifTrue: [anObject assuredPlayer] ifFalse: [anObject objectRepresented]. self flapTabs do: [:aTab | ((aTab isKindOf: ViewerFlapTab) or: [aTab hasProperty: #paintingFlap]) ifTrue: [bottomMost _ aTab bottom max: bottomMost. ((aTab isKindOf: ViewerFlapTab) and: [aTab scriptedPlayer == aPlayer]) ifTrue: [^ aTab]]]. "Not found; make a new one" tempFlapTab _ Flaps newFlapTitled: anObject nameForViewer onEdge: #right inPasteUp: self. tempFlapTab arrangeToPopOutOnDragOver: false; arrangeToPopOutOnMouseOver: false. "For some reason those event handlers were causing trouble, as reported by ar 11/22/2001, after di's flapsOnBottom update." aFlapTab _ tempFlapTab as: ViewerFlapTab. aFlapTab initializeFor: aPlayer topAt: bottomMost + 2. aFlapTab referent color: (Color green muchLighter alpha: 0.5). aFlapTab referent borderWidth: 0. aFlapTab referent setProperty: #automaticPhraseExpansion toValue: true. Preferences compactViewerFlaps ifTrue: [aFlapTab makeFlapCompact: true]. self addMorphFront: aFlapTab. aFlapTab adaptToWorld: self. ^ aFlapTab! ! !PasteUpMorph methodsFor: 'model' stamp: 'dgd 2/22/2003 14:09'! createCustomModel "Create a model object for this world if it does not yet have one. A model object is an initially empty subclass of MorphicModel. As the user names parts and adds behavior, instance variables and methods are added to this class." model isNil ifFalse: [^self]. model := MorphicModel newSubclass new! ! !PasteUpMorph methodsFor: 'objects from disk' stamp: 'tk 11/29/2004 17:31'! fixUponLoad: aProject seg: anImageSegment "We are in an old project that is being loaded from disk. Fix up conventions that have changed." self isWorldMorph ifTrue: [ (self valueOfProperty: #soundAdditions) ifNotNilDo: [:additions | SampledSound assimilateSoundsFrom: additions]]. ^ super fixUponLoad: aProject seg: anImageSegment! ! !PasteUpMorph methodsFor: 'objects from disk' stamp: 'yo 7/2/2004 13:21'! saveOnFile "Ask the user for a filename and save myself on a SmartReferenceStream file. Writes out the version and class structure. The file is fileIn-able. UniClasses will be filed out." | aFileName fileStream ok | self flag: #bob0302. self isWorldMorph ifTrue: [^self project saveAs]. aFileName _ ('my {1}' translated format: {self class name}) asFileName. "do better?" aFileName _ FillInTheBlank request: 'File name? (".project" will be added to end)' translated initialAnswer: aFileName. aFileName isEmpty ifTrue: [^ Beeper beep]. self allMorphsDo: [:m | m prepareToBeSaved]. ok _ aFileName endsWith: '.project'. "don't double them" ok _ ok | (aFileName endsWith: '.sp'). ok ifFalse: [aFileName _ aFileName,'.project']. fileStream _ FileStream newFileNamed: aFileName asFileName. fileStream fileOutClass: nil andObject: self. "Puts UniClass definitions out anyway"! ! !PasteUpMorph methodsFor: 'options' stamp: 'dgd 9/6/2003 17:55'! becomeLikeAHolder (self autoLineLayout and: [self indicateCursor]) ifTrue: [^ self inform: 'This view is ALREADY behaving like a holder, which is to say, it is set to indicate the cursor and to have auto-line-layout.' translated]. self behaveLikeHolder! ! !PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'! behaveLikeAHolderString "Answer a string to be displayed in a menu to characterize whether the receiver is currently behaving like a holder" ^ (self behavingLikeAHolder ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'behave like a holder' translated! ! !PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'! behaveLikeHolder self vResizeToFit: true; autoLineLayout: true; indicateCursor: true! ! !PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:40'! behaveLikeHolder: aBoolean "Change the receiver's viewing properties such that they conform to what we commonly call a Holder, viz: resize-to-fit, do auto-line-layout, and indicate the 'cursor'" self vResizeToFit: aBoolean; autoLineLayout: aBoolean; indicateCursor: aBoolean ! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 2/5/2001 16:59'! replaceTallSubmorphsByThumbnails "Any submorphs that seem to tall get replaced by thumbnails; their balloon text is copied over to the thumbnail" | itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails existingHelp | heightForThumbnails _ self heightForThumbnails. maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing. maxWidthForThumbnails _ self maximumThumbnailWidth. self submorphs do: [:aMorph | itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails. (aMorph == itsThumbnail) ifFalse: [existingHelp _ aMorph balloonText. self replaceSubmorph: aMorph by: itsThumbnail. existingHelp ifNotNil: [itsThumbnail setBalloonText: existingHelp]]]! ! !PasteUpMorph methodsFor: 'options' stamp: 'dgd 12/13/2003 19:30'! resizeToFitString "Answer a string, to be used in a self-updating menu, to represent whether the receiver is currently using resize-to-fit or not" ^ (self resizeToFit ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'resize to fit' translated! ! !PasteUpMorph methodsFor: 'options' stamp: 'dgd 9/6/2003 18:05'! setThumbnailHeight | reply | (self hasProperty: #alwaysShowThumbnail) ifFalse: [^ self inform: 'setting the thumbnail height is only applicable when you are currently showing thumbnails.' translated]. reply _ FillInTheBlank request: 'New height for thumbnails? ' translated initialAnswer: self heightForThumbnails printString. reply isEmpty ifTrue: [^ self]. reply _ reply asNumber. (reply > 0 and: [reply <= 150]) ifFalse: [^ self inform: 'Please be reasonable!!' translated]. self setProperty: #heightForThumbnails toValue: reply. self updateSubmorphThumbnails! ! !PasteUpMorph methodsFor: 'options' stamp: 'tk 10/30/2001 18:41'! toggleResizeToFit "Toggle whether the receiver is set to resize-to-fit" self vResizeToFit: self resizeToFit not! ! !PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 18:36'! backgroundForm ^ self backgroundSketch ifNil: [Form extent: self extent depth: Display depth] ifNotNil: [backgroundMorph form]! ! !PasteUpMorph methodsFor: 'painting' stamp: 'nk 1/6/2004 12:39'! backgroundForm: aForm self backgroundSketch: (self drawingClass new center: self center; form: aForm)! ! !PasteUpMorph methodsFor: 'painting' stamp: 'bf 10/2/2002 17:07'! backgroundSketch backgroundMorph ifNil: [^ nil]. backgroundMorph owner == self ifFalse: [backgroundMorph _ nil]. "has been deleted" ^ backgroundMorph! ! !PasteUpMorph methodsFor: 'painting' stamp: 'nk 7/4/2003 15:59'! drawSubmorphsOn: aCanvas "Display submorphs back to front, but skip my background sketch." | drawBlock | submorphs isEmpty ifTrue: [^self]. drawBlock := [:canvas | submorphs reverseDo: [:m | m ~~ backgroundMorph ifTrue: [ canvas fullDrawMorph: m ]]]. self clipSubmorphs ifTrue: [aCanvas clipBy: self clippingBounds during: drawBlock] ifFalse: [drawBlock value: aCanvas]! ! !PasteUpMorph methodsFor: 'painting' stamp: 'sw 3/24/2001 23:58'! makeNewDrawingWithin "Start a painting session in my interior which will result in a new SketchMorph being created as one of my submorphs" | evt | evt _ MouseEvent new setType: nil position: self center buttons: 0 hand: self world activeHand. self makeNewDrawing: evt! ! !PasteUpMorph methodsFor: 'painting' stamp: 'ar 6/2/2001 16:55'! paintBackground | pic rect | self world prepareToPaint. pic _ self backgroundSketch. pic ifNotNil: [pic editDrawingIn: self forBackground: true] "need to resubmit it? (tck comment)" ifNil: [rect _ self bounds. pic _ self world drawingClass new form: (Form extent: rect extent depth: Display depth). pic bounds: rect. "self world addMorphBack: pic. done below" pic _ self backgroundSketch: pic. "returns a different guy" pic ifNotNil: [pic editDrawingIn: self forBackground: true]]! ! !PasteUpMorph methodsFor: 'painting' stamp: 'ar 6/3/2001 14:01'! prepareToPaint "We're about to start painting. Do a few preparations that make the system more responsive." ^self prepareToPaint: true.! ! !PasteUpMorph methodsFor: 'painting' stamp: 'ar 6/3/2001 14:01'! prepareToPaint: stopRunningScripts "We're about to start painting. Do a few preparations that make the system more responsive." self hideViewerFlaps. "make room" stopRunningScripts ifTrue:[self stopRunningAll]. "stop scripts" self abandonAllHalos. "no more halos"! ! !PasteUpMorph methodsFor: 'parts bin' stamp: 'sw 8/2/2001 17:50'! initializeToStandAlone "Answer an instance of the receiver suitable for placing in a parts bin for authors" self initialize. self color: Color green muchLighter; extent: 100 @ 80; borderColor: (Color r: 0.645 g: 0.935 b: 0.161). self extent: 300 @ 240. self beSticky! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tak 1/18/2005 13:40'! addImageToPenTrails: aForm "The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared." self createOrResizeTrailsForm. aForm displayOn: turtleTrailsForm at: self topLeft negated rule: Form paint. self invalidRect: (aForm offset extent: aForm extent)! ! !PasteUpMorph methodsFor: 'pen' stamp: 'RAA 5/18/2001 10:47'! addImageToPenTrailsFor: aMorph "The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared." | image | self createOrResizeTrailsForm. "origin _ self topLeft." image _ aMorph imageForm offset: 0@0. image displayOn: turtleTrailsForm at: aMorph topLeft - self topLeft rule: Form paint. self invalidRect: (image boundingBox translateBy: aMorph topLeft). ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'! arrowheadsOnAllPens submorphs do: [:m | m assuredPlayer setPenArrowheads: true] ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/16/2003 12:45'! arrowsForAllPens "Set the trail style for all my objects to show arrowheads only" self trailStyleForAllPens: #arrowheads! ! !PasteUpMorph methodsFor: 'pen' stamp: 'nk 7/7/2003 11:17'! createOrResizeTrailsForm "If necessary, create a new turtleTrailsForm or resize the existing one to fill my bounds. On return, turtleTrailsForm exists and is the correct size. Use the Display depth so that color comparisons (#color:sees: and #touchesColor:) will work right." | newForm | (turtleTrailsForm isNil or: [ turtleTrailsForm extent ~= self extent ]) ifTrue: ["resize TrailsForm if my size has changed" newForm _ Form extent: self extent depth: Display depth. turtleTrailsForm ifNotNil: [ newForm copy: self bounds from: turtleTrailsForm to: 0@0 rule: Form paint ]. turtleTrailsForm _ newForm. turtlePen _ nil]. "Recreate Pen for this form" turtlePen ifNil: [turtlePen _ Pen newOnForm: turtleTrailsForm].! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/10/2003 21:15'! dotsForAllPens "Set the trail style for all my objects to show dots" self trailStyleForAllPens: #dots! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/17/2003 12:01'! drawPenTrailFor: aMorph from: oldPoint to: targetPoint "Draw a pen trail for aMorph, using its pen state (the pen is assumed to be down)." "The turtleTrailsForm is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared." | origin mPenSize offset turtleTrailsDelta newPoint aPlayer trailStyle aRadius dotSize | turtleTrailsDelta _ self valueOfProperty: #turtleTrailsDelta ifAbsent:[0@0]. newPoint _ targetPoint - turtleTrailsDelta. oldPoint = newPoint ifTrue: [^ self]. self createOrResizeTrailsForm. origin _ self topLeft. mPenSize _ aMorph getPenSize. turtlePen color: aMorph getPenColor. turtlePen sourceForm width ~= mPenSize ifTrue: [turtlePen squareNib: mPenSize]. offset _ (mPenSize // 2)@(mPenSize // 2). (#(lines arrows) includes: (trailStyle _ (aPlayer _ aMorph player) getTrailStyle)) ifTrue: [turtlePen drawFrom: (oldPoint - origin - offset) asIntegerPoint to: (newPoint - origin - offset) asIntegerPoint]. ((#(arrowheads arrows) includes: trailStyle) and: [oldPoint ~= newPoint]) ifTrue: [turtlePen arrowHeadFrom: (oldPoint - origin - offset) to: (newPoint - origin - offset) forPlayer: aPlayer]. (#(dots) includes: trailStyle) ifTrue: [dotSize _ aPlayer getDotSize. turtlePen putDotOfDiameter: dotSize at: (oldPoint - origin). turtlePen putDotOfDiameter: dotSize at: (targetPoint - origin). aRadius _ (dotSize // 2) + 1. dotSize _ dotSize + 1. "re round-off-derived gribblies" self invalidRect: ((oldPoint - origin - (aRadius @ aRadius)) extent: (dotSize @ dotSize)). self invalidRect: ((targetPoint - origin - (aRadius @ aRadius)) extent: (dotSize @ dotSize))] ifFalse: [self invalidRect: ((oldPoint rect: newPoint) expandBy: mPenSize)]! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 4/16/2003 12:27'! linesAndArrowsForAllPens "Set the trail style for all my objects to show arrows" self trailStyleForAllPens: #arrows! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 3/11/2003 11:57'! linesForAllPens "Set the trail style for all my objects to show lines only" self trailStyleForAllPens: #lines! ! !PasteUpMorph methodsFor: 'pen' stamp: 'tk 10/4/2001 18:03'! noArrowheadsOnAllPens submorphs do: [:m | m assuredPlayer setPenArrowheads: false] ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'sw 3/11/2003 11:40'! trailStyleForAllPens: aTrailStyle "Ascribe the given trail style to all pens of objects within me" submorphs do: [:m | m assuredPlayer setTrailStyle: aTrailStyle] ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'dgd 2/22/2003 14:12'! updateTrailsForm "Update the turtle-trails form using the current positions of all pens. Only used in conjunction with Preferences batchPenTrails." "Details: The positions of all morphs with their pens down are recorded each time the draw method is called. If the list from the previous display cycle isn't empty, then trails are drawn from the old to the new positions of those morphs on the turtle-trails form. The turtle-trails form is created on demand when the first pen is put down and removed (to save space) when turtle trails are cleared." | morph oldPoint newPoint removals player tfm | self flag: #bob. "transformations WRONG here" (lastTurtlePositions isNil or: [lastTurtlePositions isEmpty]) ifTrue: [^self]. removals := OrderedCollection new. lastTurtlePositions associationsDo: [:assoc | player := assoc key. morph := player costume. (player getPenDown and: [morph trailMorph == self]) ifTrue: [oldPoint := assoc value. tfm := morph owner transformFrom: self. newPoint := tfm localPointToGlobal: morph referencePosition. newPoint = oldPoint ifFalse: [assoc value: newPoint. self drawPenTrailFor: morph from: oldPoint to: newPoint]] ifFalse: [removals add: player]]. removals do: [:key | lastTurtlePositions removeKey: key ifAbsent: []]! ! !PasteUpMorph methodsFor: 'project' stamp: 'gm 2/16/2003 20:35'! storeProjectsAsSegments "Force my sub-projects out to disk" submorphs do: [:sub | (sub isSystemWindow) ifTrue: [(sub model isKindOf: Project) ifTrue: [sub model storeSegment]]] "OK if was already out"! ! !PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:47'! handsDo: aBlock ^ worldState ifNotNil: [ worldState handsDo: aBlock ]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:46'! handsReverseDo: aBlock ^ worldState ifNotNil: [ worldState handsReverseDo: aBlock ]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:12'! viewBox: newViewBox "I am now displayed within newViewBox; react." self isWorldMorph ifTrue: [(self viewBox isNil or: [self viewBox extent ~= newViewBox extent]) ifTrue: [worldState canvas: nil]. worldState viewBox: newViewBox]. super position: newViewBox topLeft. fullBounds := bounds := newViewBox. "Paragraph problem workaround; clear selections to avoid screen droppings." self flag: #arNote. "Probably unnecessary" self isWorldMorph ifTrue: [worldState handsDo: [:hand | hand releaseKeyboardFocus]. self fullRepaintNeeded]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'sw 7/22/2001 00:55'! abandonOldReferenceScheme "Perform a one-time changeover" "ActiveWorld abandonOldReferenceScheme" Preferences setPreference: #capitalizedReferences toValue: true. (self presenter allExtantPlayers collect: [:aPlayer | aPlayer class]) asSet do: [:aPlayerClass | aPlayerClass isUniClass ifTrue: [aPlayerClass abandonOldReferenceScheme]]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:12'! adaptedToWorld: aWorld "If I refer to a world or a hand, return the corresponding items in the new world." self isWorldMorph ifTrue:[^aWorld].! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'nk 8/29/2004 17:17'! currentVocabularyFor: aScriptableObject "Answer the Vocabulary object to be applied when scripting an object in the world." | vocabSymbol vocab aPointVocab | vocabSymbol := self valueOfProperty: #currentVocabularySymbol ifAbsent: [nil]. vocabSymbol ifNil: [vocab := self valueOfProperty: #currentVocabulary ifAbsent: [nil]. vocab ifNotNil: [vocabSymbol := vocab vocabularyName. self removeProperty: #currentVocabulary. self setProperty: #currentVocabularySymbol toValue: vocabSymbol]]. vocabSymbol ifNotNil: [^Vocabulary vocabularyNamed: vocabSymbol] ifNil: [(aScriptableObject isPlayerLike) ifTrue: [^Vocabulary eToyVocabulary]. (aScriptableObject isNumber) ifTrue: [^Vocabulary numberVocabulary]. (aScriptableObject isKindOf: Time) ifTrue: [^Vocabulary vocabularyForClass: Time]. (aScriptableObject isString) ifTrue: [^Vocabulary vocabularyForClass: String]. (aScriptableObject isPoint) ifTrue: [(aPointVocab := Vocabulary vocabularyForClass: Point) ifNotNil: [^aPointVocab]]. (aScriptableObject isKindOf: Date) ifTrue: [^Vocabulary vocabularyForClass: Date]. "OrderedCollection and Holder??" ^Vocabulary fullVocabulary]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/18/2003 02:56'! elementCount "Answer how many objects are contained within me" ^ submorphs size! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/18/2003 01:46'! getCharacters "obtain a string value from the receiver" ^ String streamContents: [:aStream | submorphs do: [:m | aStream nextPutAll: m getCharacters]]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'dgd 8/31/2003 19:39'! modernizeBJProject "Prepare a kids' project from the BJ fork of September 2000 -- a once-off thing for converting such projects forward to a modern 3.1a image, in July 2001. Except for the #enableOnlyGlobalFlapsWithIDs: call, this could conceivably be called upon reloading *any* project, just for safety." "ActiveWorld modernizeBJProject" ScriptEditorMorph allInstancesDo: [:m | m userScriptObject]. Flaps enableOnlyGlobalFlapsWithIDs: {'Supplies' translated}. ActiveWorld abandonOldReferenceScheme. ActiveWorld relaunchAllViewers.! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:09'! recreateScripts "self currentWorld recreateScripts." Preferences enable: #universalTiles. Preferences enable: #capitalizedReferences. "Rebuild viewers" self flapTabs do: [:ff | (ff isMemberOf: ViewerFlapTab) ifTrue: [ff referent submorphsDo: [:m | (m isStandardViewer) ifTrue: [m recreateCategories]]]]. "Rebuild scriptors" ((self flapTabs collect: [:t | t referent]) copyWith: self) do: [:w | w allScriptEditors do: [:scrEd | scrEd unhibernate]]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'gm 2/22/2003 13:09'! relaunchAllViewers "Relaunch all the viewers in the project" | aViewer | (self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do: [:aTab | aViewer := aTab referent submorphs detect: [:sm | sm isStandardViewer] ifNone: [nil]. aViewer ifNotNil: [aViewer relaunchViewer] "ActiveWorld relaunchAllViewers"]! ! !PasteUpMorph methodsFor: 'scripting' stamp: 'sw 2/20/2003 13:06'! tellAllContents: aMessageSelector "Send the given message selector to all the objects within the receiver" self submorphs do: [:m | m player ifNotNilDo: [:p | p performScriptIfCan: aMessageSelector]]! ! !PasteUpMorph methodsFor: 'structure' stamp: 'dgd 2/22/2003 14:12'! world worldState isNil ifTrue: [^super world]. ^self! ! !PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'nk 7/4/2003 16:49'! morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock "Include hands if the receiver is the World" self handsDo:[:m| m == someMorph ifTrue:["Try getting out quickly" owner ifNil:[^self]. ^owner morphsInFrontOf: self overlapping: aRectangle do: aBlock]. "The hand only overlaps if it's not the hardware cursor" m needsToBeDrawn ifTrue:[ (m fullBoundsInWorld intersects: aRectangle) ifTrue:[aBlock value: m]]]. ^super morphsInFrontOf: someMorph overlapping: aRectangle do: aBlock! ! !PasteUpMorph methodsFor: 'user interface' stamp: 'dgd 2/22/2003 14:11'! modelWakeUp "I am the model of a SystemWindow, that has just been activated" | aWindow | owner isNil ifTrue: [^self]. "Not in Morphic world" (owner isKindOf: TransformMorph) ifTrue: [^self viewBox: self fullBounds]. (aWindow := self containingWindow) ifNotNil: [self viewBox = aWindow panelRect ifFalse: [self viewBox: aWindow panelRect]]! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'sw 7/20/2002 12:52'! scriptSelectorToTriggerFor: aButtonMorph "Answer a new selector which will bear the code for aButtonMorph in the receiver" | buttonName selectorName | buttonName _ aButtonMorph externalName. selectorName _ self assuredPlayer acceptableScriptNameFrom: buttonName forScriptCurrentlyNamed: nil. buttonName ~= selectorName ifTrue: [aButtonMorph setNameTo: selectorName]. ^ selectorName! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'! viewingByIconString "Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by icon or not" ^ ((self showingListView or: [self autoLineLayout == true]) ifTrue: ['<no>'] ifFalse: ['<yes>']), 'view by icon' translated! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'! viewingByNameString "Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by name or not" ^ ((self showingListView and: [(self valueOfProperty: #sortOrder ifAbsent: []) == #downshiftedNameOfObjectRepresented]) ifTrue: ['<yes>'] ifFalse: ['<no>']), 'view by name' translated! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:50'! viewingBySizeString "Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by size or not" ^ ((self showingListView and: [(self valueOfProperty: #sortOrder ifAbsent: []) == #reportableSize]) ifTrue: ['<yes>'] ifFalse: ['<no>']), 'view by size' translated! ! !PasteUpMorph methodsFor: 'viewing' stamp: 'dgd 9/6/2003 17:51'! viewingNonOverlappingString "Answer a string to show in a menu representing whether the receiver is currently viewing its subparts by non-overlapping-icon (aka auto-line-layout)" ^ ((self showingListView or: [self autoLineLayout ~~ true]) ifTrue: ['<no>'] ifFalse: ['<yes>']), 'view with line layout' translated! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 8/12/2001 17:47'! activateObjectsTool "Offer the user a parts bin of morphs -- if one already exists, bring it to the front and flash its border beckoningly; if none exists yet, create a new one and place it in the center of the screen" | anObjectTool | submorphs do: [:aMorph | (aMorph renderedMorph isKindOf: ObjectsTool) ifTrue: [aMorph comeToFront. aMorph flash. ^ self]]. "None found, so create one" anObjectTool _ ObjectsTool newStandAlone. self addMorphFront: anObjectTool. anObjectTool fullBounds. anObjectTool center: self center "ActiveWorld activateObjectsTool"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 6/6/2004 13:16'! attemptCleanup "Try to fix up some bad things that are known to occur in some etoy projects we've seen. This is a bare beginning, but a useful place to tack on further cleanups, which then can be invoked whenever the attempt-cleanup item invoked from the debug menu" self attemptCleanupReporting: true " ActiveWorld attemptCleanup "! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'yo 3/15/2005 13:36'! attemptCleanupReporting: whetherToReport "Try to fix up some bad things that are known to occur in some etoy projects we've seen. If the whetherToReport parameter is true, an informer is presented after the cleanups" | fixes | fixes _ 0. ActiveWorld ifNotNil: [(ActiveWorld submorphs select: [:m | (m isKindOf: ScriptEditorMorph) and: [m submorphs isEmpty]]) do: [:m | m delete. fixes _ fixes + 1]]. TransformationMorph allSubInstancesDo: [:m | (m player notNil and: [m renderedMorph ~~ m]) ifTrue: [m renderedMorph visible ifFalse: [m renderedMorph visible: true. fixes _ fixes + 1]]]. (Player class allSubInstances select: [:cl | cl isUniClass]) do: [:aUniclass | fixes _ fixes + aUniclass cleanseScripts]. self presenter flushPlayerListCache; allExtantPlayers. whetherToReport ifTrue: [self inform: ('{1} [or more] repair(s) made' translated format: {fixes printString})] " ActiveWorld attemptCleanupReporting: true. ActiveWorld attemptCleanupReporting: false. "! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 6/4/2004 15:00'! browseAllScriptsTextually "Put up a browser showing all scripts in the project textually" self presenter browseAllScriptsTextually "ActiveWorld browseAllScriptsTextually"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/21/2003 17:39'! closeUnchangedWindows "Present a menu of window titles for all windows with changes, and activate the one that gets chosen." (SelectionMenu confirm: 'Do you really want to close all windows except those with unaccepted edits?' translated) ifFalse: [^ self]. (SystemWindow windowsIn: self satisfying: [:w | w model canDiscardEdits]) do: [:w | w delete]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'! commandKeySelectors "Answer my command-key table" | aDict | aDict _ self valueOfProperty: #commandKeySelectors ifAbsentPut: [self initializeDesktopCommandKeySelectors]. ^ aDict! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'mir 11/14/2002 17:37'! connectRemoteUserWithName: nameStringOrNil picture: aFormOrNil andIPAddress: aStringOrNil "Prompt for the initials to be used to identify the cursor of a remote user, then create a cursor for that user and wait for a connection." | initials addr h | initials _ nameStringOrNil. initials isEmptyOrNil ifTrue: [ initials _ FillInTheBlank request: 'Enter initials for remote user''s cursor?'. ]. initials isEmpty ifTrue: [^ self]. "abort" addr _ 0. aStringOrNil isEmptyOrNil ifFalse: [ addr _ NetNameResolver addressForName: aStringOrNil timeout: 30 ]. addr = 0 ifTrue: [ addr _ NetNameResolver promptUserForHostAddress. ]. addr = 0 ifTrue: [^ self]. "abort" RemoteHandMorph ensureNetworkConnected. h _ RemoteHandMorph new userInitials: initials andPicture: aFormOrNil. self addHand: h. h changed. h startListening. h startTransmittingEventsTo: addr. ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'hpt 8/5/2004 20:28'! defaultDesktopCommandKeyTriplets "Answer a list of triplets of the form <key> <receiver> <selector> [+ optional fourth element, a <description> for use in desktop-command-key-help] that will provide the default desktop command key handlers. If the selector takes an argument, that argument will be the command-key event" ^ { { $b. SystemBrowser. #defaultOpenBrowser. 'Open a new System Browser'}. { $k. Workspace. #open. 'Open a new, blank Workspace'}. { $m. self. #putUpNewMorphMenu. 'Put up the "New Morph" menu'}. { $o. ActiveWorld. #activateObjectsTool. 'Activate the "Objects Tool"'}. { $r. ActiveWorld. #restoreMorphicDisplay. 'Redraw the screen'}. { $t. self. #findATranscript:. 'Make a System Transcript visible'}. { $w. SystemWindow. #closeTopWindow. 'Close the topmost window'}. { $z. self. #undoOrRedoCommand. 'Undo or redo the last undoable command'}. { $C. self. #findAChangeSorter:. 'Make a Change Sorter visible'}. { $F. CurrentProjectRefactoring. #currentToggleFlapsSuppressed. 'Toggle the display of flaps'}. { $L. self. #findAFileList:. 'Make a File List visible'}. { $N. self. #toggleClassicNavigatorIfAppropriate. 'Show/Hide the classic Navigator, if appropriate'}. { $P. self. #findAPreferencesPanel:. 'Activate the Preferences tool'}. { $R. self. #openRecentSubmissionsBrowser: . 'Make a Recent Submissions browser visible'}. { $W. self. #findAMessageNamesWindow:. 'Make a MessageNames tool visible'}. { $Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes'}. { $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}.}! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/11/2004 20:45'! delayedInvokeWorldMenu: evt self addAlarm: #invokeWorldMenu: with: evt after: 200! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/21/2003 17:40'! deleteNonWindows (SelectionMenu confirm: 'Do you really want to discard all objects that are not in windows?' translated) ifFalse: [^ self]. self allNonFlapRelatedSubmorphs do: [:m | m delete]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:19'! dispatchCommandKeyInWorld: aChar event: evt "Dispatch the desktop command key if possible. Answer whether handled" | aMessageSend | aMessageSend _ self commandKeySelectors at: aChar ifAbsent: [^ false]. aMessageSend selector numArgs = 0 ifTrue: [aMessageSend value] ifFalse: [aMessageSend valueWithArguments: (Array with: evt)]. ^ true ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:38'! extractScreenRegion: poly andPutSketchInHand: hand "The user has specified a polygonal area of the Display. Now capture the pixels from that region, and put in the hand as a Sketch." | screenForm outline topLeft innerForm exterior | outline _ poly shadowForm. topLeft _ outline offset. exterior _ (outline offset: 0@0) anyShapeFill reverse. screenForm _ Form fromDisplay: (topLeft extent: outline extent). screenForm eraseShape: exterior. innerForm _ screenForm trimBordersOfColor: Color transparent. innerForm isAllWhite ifFalse: [hand attachMorph: (self drawingClass withForm: innerForm)]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:47'! findAChangeSorter: evt "Locate a change sorter, open it, and bring it to the front. Create one if necessary" self findAWindowSatisfying: [:aWindow | (aWindow model isMemberOf: ChangeSorter) or: [aWindow model isKindOf: DualChangeSorter]] orMakeOneUsing: [DualChangeSorter new morphicWindow]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nk 6/14/2004 09:08'! findAFileList: evt "Locate a file list, open it, and bring it to the front. Create one if necessary, respecting the Preference." self findAWindowSatisfying: [:aWindow | aWindow model isKindOf: FileList] orMakeOneUsing: [Preferences useFileList2 ifTrue: [FileList2 prototypicalToolWindow] ifFalse: [FileList prototypicalToolWindow]]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 13:53'! findAMessageNamesWindow: evt "Locate a MessageNames tool, open it, and bring it to the front. Create one if necessary" self findAWindowSatisfying: [:aWindow | aWindow model isKindOf: MessageNames] orMakeOneUsing: [MessageNames new inMorphicWindowLabeled: 'Message Names']! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 16:19'! findAPreferencesPanel: evt "Locate a Preferences Panel, open it, and bring it to the front. Create one if necessary" | aPanel | self findAWindowSatisfying: [:aWindow | aWindow model isKindOf: PreferencesPanel] orMakeOneUsing: [aPanel _ Preferences preferencesControlPanel. "Note -- we don't really want the openInHand -- but owing to some annoying difficulty, if we don't, we get the wrong width. Somebody please clean this up" ^ aPanel openInHand]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/22/2002 08:54'! findATranscript: evt "Locate a transcript, open it, and bring it to the front. Create one if necessary" self findAWindowSatisfying: [:aWindow | aWindow model == Transcript] orMakeOneUsing: [Transcript openAsMorphLabel: 'Transcript']! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'gm 2/16/2003 20:35'! findAWindowSatisfying: qualifyingBlock orMakeOneUsing: makeBlock "Locate a window satisfying a block, open it, and bring it to the front. Create one if necessary, by using the makeBlock" | aWindow | submorphs do: [:aMorph | (((aWindow := aMorph renderedMorph) isSystemWindow) and: [qualifyingBlock value: aWindow]) ifTrue: [aWindow isCollapsed ifTrue: [aWindow expand]. aWindow activateAndForceLabelToShow. ^self]]. "None found, so create one" makeBlock value openInWorld! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 2/22/2003 14:10'! findDirtyBrowsers: evt "Present a menu of window titles for browsers with changes, and activate the one that gets chosen." | menu | menu := MenuMorph new. (SystemWindow windowsIn: self satisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]]) do: [:w | menu add: w label target: w action: #activate]. menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 2/22/2003 14:10'! findDirtyWindows: evt "Present a menu of window titles for all windows with changes, and activate the one that gets chosen." | menu | menu := MenuMorph new. (SystemWindow windowsIn: self satisfying: [:w | w model canDiscardEdits not]) do: [:w | menu add: w label target: w action: #activate]. menu submorphs notEmpty ifTrue: [menu popUpEvent: evt in: self]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sd 11/13/2003 21:25'! findWindow: evt "Present a menu names of windows and naked morphs, and activate the one that gets chosen. Collapsed windows appear below line, expand if chosen; naked morphs appear below second line; if any of them has been given an explicit name, that is what's shown, else the class-name of the morph shows; if a naked morph is chosen, bring it to front and have it don a halo." | menu expanded collapsed nakedMorphs | menu _ MenuMorph new. expanded _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed not]. collapsed _ SystemWindow windowsIn: self satisfying: [:w | w isCollapsed]. nakedMorphs _ self submorphsSatisfying: [:m | (m isSystemWindow not and: [(m isKindOf: StickySketchMorph) not]) and: [(m isFlapTab) not]]. (expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep]. (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #activateAndForceLabelToShow. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. (expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine]. (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #collapseOrExpand. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. nakedMorphs isEmpty ifFalse: [menu addLine]. (nakedMorphs asSortedCollection: [:w1 :w2 | w1 nameForFindWindowFeature caseInsensitiveLessOrEqual: w2 nameForFindWindowFeature]) do: [:w | menu add: w nameForFindWindowFeature target: w action: #comeToFrontAndAddHalo]. menu addTitle: 'find window' translated. menu popUpEvent: evt in: self.! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/28/2004 16:34'! galleryOfPlayers "Put up a tool showing all the players in the project" (ActiveWorld findA: AllPlayersTool) ifNotNilDo: [:aTool | ^ aTool comeToFront]. AllPlayersTool newStandAlone openInHand "ActiveWorld galleryOfPlayers"! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 03:33'! grabDrawingFromScreen: evt "Allow the user to specify a rectangular area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." | m | m _ self drawingClass new form: Form fromUser. evt hand position: Sensor cursorPoint. "update hand pos after Sensor loop in fromUser" evt hand attachMorph: m.! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nk 1/6/2004 12:39'! grabFloodFromScreen: evt "Allow the user to plant a flood seed on the Display, and create a new drawing morph from the resulting region. Attach the result to the hand." | screenForm exterior p1 box | Cursor crossHair showWhile: [p1 _ Sensor waitButton]. box _ Display floodFill: Color transparent at: p1. exterior _ ((Display copy: box) makeBWForm: Color transparent) reverse. self world invalidRect: box; displayWorldSafely. (box area > (Display boundingBox area // 2)) ifTrue: [^ PopUpMenu notify: 'Sorry, the region was too big']. (exterior deepCopy reverse anyShapeFill reverse) "save interior bits" displayOn: exterior at: 0@0 rule: Form and. screenForm _ Form fromDisplay: box. screenForm eraseShape: exterior. screenForm isAllWhite ifFalse: [evt hand attachMorph: (self drawingClass withForm: screenForm)]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 02:58'! grabLassoFromScreen: evt "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." self extractScreenRegion: (PolygonMorph fromHandFreehand: evt hand) andPutSketchInHand: evt hand ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 10/18/2001 01:13'! grabRubberBandFromScreen: evt "Allow the user to specify a polygonal area of the Display, capture the pixels from that area, and use them to create a new drawing morph. Attach the result to the hand." self extractScreenRegion: (PolygonMorph fromHand: evt hand) andPutSketchInHand: evt hand! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:52'! initializeDesktopCommandKeySelectors "Provide the starting settings for desktop command key selectors. Answer the dictionary." "ActiveWorld initializeDesktopCommandKeySelectors" | dict messageSend | dict _ IdentityDictionary new. self defaultDesktopCommandKeyTriplets do: [:trip | messageSend _ MessageSend receiver: trip second selector: trip third. dict at: trip first put: messageSend]. self setProperty: #commandKeySelectors toValue: dict. ^ dict ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 4/30/2001 21:03'! invokeWorldMenu: evt "Put up the world menu, triggered by the passed-in event. But don't do it if the eToyFriendly preference is set to true." Preferences eToyFriendly ifFalse: [self putUpWorldMenu: evt]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 5/20/2003 15:04'! keyboardNavigationHandler "Answer the receiver's existing keyboardNavigationHandler, or nil if none." | aHandler | aHandler _ self valueOfProperty: #keyboardNavigationHandler ifAbsent: [^ nil]. (aHandler hasProperty: #moribund) ifTrue: "got clobbered in another project" [self removeProperty: #keyboardNavigationHander. ^ nil]. ^ aHandler! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/18/2003 23:10'! keyboardNavigationHandler: aHandler "Set the receiver's keyboard navigation handler as indicated. A nil argument means to remove the handler" aHandler ifNil: [self removeProperty: #keyboardNavigationHandler] ifNotNil: [self setProperty: #keyboardNavigationHandler toValue: aHandler]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'tak 1/26/2005 22:08'! keystrokeInWorld: evt "A keystroke was hit when no keyboard focus was set, so it is sent here to the world instead." | aChar isCmd ascii | aChar _ evt keyCharacter. (ascii _ aChar asciiValue) = 27 ifTrue: "escape key" [^ self putUpWorldMenuFromEscapeKey]. (evt controlKeyPressed not and: [(#(1 4 8 28 29 30 31 32) includes: ascii) "home, end, backspace, arrow keys, space" and: [self keyboardNavigationHandler notNil]]) ifTrue: [self keyboardNavigationHandler navigateFromKeystroke: aChar]. isCmd _ evt commandKeyPressed and: [Preferences cmdKeysInText]. (evt commandKeyPressed and: [Preferences eToyFriendly]) ifTrue: [(aChar == $W) ifTrue: [^ self putUpWorldMenu: evt]]. (isCmd and: [Preferences honorDesktopCmdKeys]) ifTrue: [^ self dispatchCommandKeyInWorld: aChar event: evt]. "It was unhandled. Remember the keystroke." self lastKeystroke: evt keyString. self triggerEvent: #keyStroke! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'nk 10/14/2004 07:07'! makeAllScriptEditorsReferToMasters "Ensure that all script editors refer to the first (by alphabetical externalName) Player among the list of siblings" (self presenter allExtantPlayers groupBy: [ :p | p class ] having: [ :p | true ]) do: [ :group | group first allScriptEditors ]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'ar 2/8/2001 19:26'! makeNewDrawing: evt ^self makeNewDrawing: evt at: evt position! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 12/12/2001 11:36'! makeNewDrawing: evt at: aPoint "make a new drawing, triggered by the given event, with the painting area centered around the given point" | w newSketch newPlayer sketchEditor aPaintBox aPalette tfx whereToPresent rect ownerBeforeHack aPaintTab aWorld | w _ self world. w assureNotPaintingElse: [^ self]. rect _ self paintingBoundsAround: aPoint. aPalette _ self standardPalette. aPalette ifNotNil: [aPalette showNoPalette; layoutChanged]. w prepareToPaint. newSketch _ self drawingClass new player: (newPlayer _ UnscriptedPlayer newUserInstance). newPlayer costume: newSketch. newSketch nominalForm: (Form extent: rect extent depth: w assuredCanvas depth). newSketch bounds: rect. sketchEditor _ SketchEditorMorph new. w addMorphFront: sketchEditor. sketchEditor initializeFor: newSketch inBounds: rect pasteUpMorph: self. sketchEditor afterNewPicDo: [:aForm :aRect | whereToPresent _ self presenter. newSketch form: aForm. tfx _ self transformFrom: w. newSketch position: (tfx globalPointToLocal: aRect origin). newSketch rotationStyle: sketchEditor rotationStyle. newSketch forwardDirection: sketchEditor forwardDirection. ownerBeforeHack _ newSketch owner. "about to break the invariant!!!!" newSketch privateOwner: self. "temp for halo access" newPlayer setHeading: sketchEditor forwardDirection. (aPaintTab _ (aWorld _ self world) paintingFlapTab) ifNotNil:[aPaintTab hideFlap] ifNil:[(aPaintBox _ aWorld paintBox) ifNotNil:[aPaintBox delete]]. "Includes newSketch rotationDegrees: sketchEditor forwardDirection." newSketch privateOwner: ownerBeforeHack. "probably nil, but let's be certain" self addMorphFront: newPlayer costume. w startSteppingSubmorphsOf: newSketch. whereToPresent drawingJustCompleted: newSketch] ifNoBits:[ (aPaintTab _ (aWorld _ self world) paintingFlapTab) ifNotNil:[aPaintTab hideFlap] ifNil:[(aPaintBox _ aWorld paintBox) ifNotNil:[aPaintBox delete]]. aPalette ifNotNil: [aPalette showNoPalette].]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 7/23/2002 14:01'! openRecentSubmissionsBrowser: evt "Locate a recent-submissions browser, open it, and bring it to the front. Create one if necessary. Only works in morphic" self findAWindowSatisfying: [:aWindow | aWindow model isKindOf: RecentMessageSet] orMakeOneUsing: [Utilities recentSubmissionsWindow] ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 2/7/2001 20:10'! openScrapsBook: evt "Open up the Scraps book in the center of the screen" evt hand world addMorphCentered: Utilities scrapsBook! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 8/26/2003 21:10'! putUpDesktopMenu: evt "Put up the desktop menu" ^ ((self buildWorldMenu: evt) addTitle: Preferences desktopMenuTitle translated) popUpAt: evt position forHand: evt hand in: self! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 11:51'! putUpNewMorphMenu "Put up the New Morph menu in the world" TheWorldMenu new adaptToWorld: self; newMorph! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 8/31/2004 16:25'! putUpWorldMenu: evt "Put up a menu in response to a click on the desktop, triggered by evt." | menu | self bringTopmostsToFront. evt isMouse ifTrue: [evt yellowButtonPressed ifTrue: [^ self yellowButtonClickOnDesktopWithEvent: evt]. evt shiftPressed ifTrue:[^ self findWindow: evt]]. "put up screen menu" menu _ self buildWorldMenu: evt. menu addTitle: Preferences desktopMenuTitle translated. menu popUpEvent: evt in: self. ^ menu! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'di 12/10/2001 22:02'! putUpWorldMenuFromEscapeKey ^ self putUpWorldMenu: ActiveEvent! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 5/3/2001 20:56'! removeAllViewers "Delete all the viewers lined up along my right margin." (self submorphs select: [:m | m isKindOf: ViewerFlapTab]) do: [:m | m referent ifNotNil: [m referent delete]. m delete.]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 13:56'! respondToCommand: aCharacter bySending: aSelector to: aReceiver "Respond to the command-key use of the given character by sending the given selector to the given receiver. If the selector is nil, retract any prior such setting" aSelector ifNil: [self commandKeySelectors removeKey: aCharacter] ifNotNil: [self commandKeySelectors at: aCharacter put: (MessageSend receiver: aReceiver selector: aSelector)]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 11:58'! toggleClassicNavigatorIfAppropriate "If appropriate, toggle the presence of classic navigator" Preferences classicNavigatorEnabled ifTrue: [^ Preferences togglePreference: #showProjectNavigator]! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'sw 3/13/2003 12:25'! undoOrRedoCommand "Undo or redo the last command recorded in the world" ^ self commandHistory undoOrRedoCommand! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'dgd 9/19/2003 11:22'! yellowButtonClickOnDesktopWithEvent: evt "Put up either the personalized menu or the world menu when the user clicks on the morphic desktop with the yellow button. The preference 'personalizedWorldMenu' governs which one is used" | aMenu | Preferences personalizedWorldMenu ifTrue: [aMenu := MenuMorph new defaultTarget: self. Preferences personalizeUserMenu: aMenu. aMenu addLine. aMenu add: 'personalize...' translated target: Preferences action: #letUserPersonalizeMenu] ifFalse: [aMenu := self buildWorldMenu: evt. aMenu addTitle: 'World' translated]. aMenu popUpEvent: evt in: self! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/13/2001 10:06'! abandonVocabularyPreference "Remove any memory of a preferred vocabulary in the project" self removeProperty: #currentVocabularySymbol "ActiveWorld abandonVocabularyPreference"! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:09'! addMorphsAndModel: aMorphOrList "Dump in submorphs, model, and stepList from aMorphOrList. Used to bring a world, paste-up, or other morph in from an object file." aMorphOrList isMorph ifTrue: [aMorphOrList isWorldMorph ifFalse: ["one morph, put on hand" "aMorphOrList installModelIn: self. a chance to install model pointers" aMorphOrList privateOwner: nil. self firstHand attachMorph: aMorphOrList. self startSteppingSubmorphsOf: aMorphOrList] ifTrue: [model isNil ifTrue: [self setModel: aMorphOrList modelOrNil] ifFalse: [aMorphOrList modelOrNil ifNotNil: [aMorphOrList modelOrNil privateOwner: nil. self addMorph: aMorphOrList modelOrNil]]. aMorphOrList privateSubmorphs reverseDo: [:m | m privateOwner: nil. self addMorph: m. m changed]. (aMorphOrList instVarNamed: 'stepList') do: [:entry | entry first startSteppingIn: self]]] ifFalse: ["list, add them all" aMorphOrList reverseDo: [:m | m privateOwner: nil. self addMorph: m. self startSteppingSubmorphsOf: m. "It may not want this!!" m changed]]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:23'! allNonFlapRelatedSubmorphs "Answer all non-window submorphs that are not flap-related" ^submorphs select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'yo 2/17/2005 14:49'! assureNotPaintingElse: aBlock "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock" self sketchEditorOrNil ifNotNil: [self inform: 'Sorry, you can only paint one object at a time' translated. Cursor normal show. ^ aBlock value] ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/18/2000 01:16'! assureNotPaintingEvent: evt "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock" | editor | (editor _ self sketchEditorOrNil) ifNotNil:[ editor save: evt. Cursor normal show. ].! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:57'! checkCurrentHandForObjectToPaste | response | self primaryHand pasteBuffer ifNil: [^self]. response _ (PopUpMenu labels: 'Delete\Keep' withCRs) startUpWithCaption: 'Hand is holding a Morph in its paste buffer:\' withCRs, self primaryHand pasteBuffer printString. response = 1 ifTrue: [self primaryHand pasteBuffer: nil]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/17/2001 23:57'! checkCurrentHandForObjectToPaste2 self primaryHand pasteBuffer ifNil: [^self]. self inform: 'Hand is holding a Morph in its paste buffer:\' withCRs, self primaryHand pasteBuffer printString. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10'! displayWorldNonIncrementally "Display the morph world non-incrementally. Used for testing." (worldState canvas isNil or: [worldState canvas extent ~= self viewBox extent or: [worldState canvas form depth ~= Display depth]]) ifTrue: ["allocate a new offscreen canvas the size of the window" worldState canvas: (Display defaultCanvasClass extent: self viewBox extent)]. worldState canvas fillColor: color. submorphs reverseDo: [:m | worldState canvas fullDrawMorph: m]. worldState handsReverseDo: [:h | worldState canvas fullDrawMorph: h]. worldState canvas form displayOn: Display at: self viewBox origin. self fullRepaintNeeded. "don't collect damage" Display forceDisplayUpdate! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ls 5/6/2003 16:51'! doOneCycle "see the comment in doOneCycleFor:" worldState doOneCycleFor: self! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 12/19/2000 19:23'! endDrawing: evt "If painting is already underway in the receiver, finish and save it." | editor | (editor _ self sketchEditorOrNil) ifNotNil:[ editor save: evt. Cursor normal show. ].! ! !PasteUpMorph methodsFor: 'world state' stamp: 'mir 9/12/2001 15:18'! initForProject: aWorldState worldState _ aWorldState. bounds _ Display boundingBox. color _ (Color r:0.937 g: 0.937 b: 0.937). self addHand: HandMorph new. self setProperty: #automaticPhraseExpansion toValue: true. self setProperty: #optimumExtentFromAuthor toValue: Display extent. self wantsMouseOverHalos: Preferences mouseOverHalos. self borderWidth: 0. model _ nil. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:10'! install owner := nil. "since we may have been inside another world previously" ActiveWorld := self. ActiveHand := self hands first. "default" ActiveEvent := nil. submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]]. "Transcript that was in outPointers and then got deleted." self viewBox: Display boundingBox. Sensor flushAllButDandDEvents. worldState handsDo: [:h | h initForEvents]. self installFlaps. self borderWidth: 0. "default" (Preferences showSecurityStatus and: [SecurityManager default isInRestrictedMode]) ifTrue: [self borderWidth: 2; borderColor: Color red]. self presenter allExtantPlayers do: [:player | player prepareToBeRunning]. SystemWindow noteTopWindowIn: self. self displayWorldSafely! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11'! installAsActiveSubprojectIn: enclosingWorld at: newBounds titled: aString | window howToOpen tm boundsForWorld | howToOpen := self embeddedProjectDisplayMode. "#scaled may be the only one that works at the moment" submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]]. "Transcript that was in outPointers and then got deleted." boundsForWorld := howToOpen == #naked ifTrue: [newBounds] ifFalse: [bounds]. worldState canvas: nil. worldState viewBox: boundsForWorld. self bounds: boundsForWorld. "self viewBox: Display boundingBox." "worldState handsDo: [:h | h initForEvents]." self installFlaps. "SystemWindow noteTopWindowIn: self." "self displayWorldSafely." howToOpen == #naked ifTrue: [enclosingWorld addMorphFront: self]. howToOpen == #window ifTrue: [window := (NewWorldWindow labelled: aString) model: self. window addMorph: self frame: (0 @ 0 extent: 1.0 @ 1.0). window openInWorld: enclosingWorld]. howToOpen == #frame ifTrue: [window := (AlignmentMorphBob1 new) minWidth: 100; minHeight: 100; borderWidth: 8; borderColor: Color green; bounds: newBounds. window addMorph: self. window openInWorld: enclosingWorld]. howToOpen == #scaled ifTrue: [self position: 0 @ 0. window := (EmbeddedWorldBorderMorph new) minWidth: 100; minHeight: 100; borderWidth: 8; borderColor: Color green; bounds: newBounds. tm := BOBTransformationMorph new. window addMorph: tm. tm addMorph: self. window openInWorld: enclosingWorld. tm changeWorldBoundsToShow: bounds. self arrangeToStartSteppingIn: enclosingWorld "tm scale: (tm width / self width min: tm height / self height) asFloat."]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:25'! installFlaps "Get flaps installed within the bounds of the receiver" Project current assureFlapIntegrity. self addGlobalFlaps. self localFlapTabs do: [:aFlapTab | aFlapTab adaptToWorld]. self assureFlapTabsFitOnScreen. self bringTopmostsToFront! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/13/2001 09:44'! installVectorVocabulary "Install the experimental Vector vocabulary as the default for the current project" self setProperty: #currentVocabularySymbol toValue: #Vector! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! nextPage "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful" Beeper beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 19:01'! paintAreaFor: aSketchMorph "Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph" | itsOwner | ((itsOwner := aSketchMorph owner) notNil and: [itsOwner isPlayfieldLike]) ifTrue: [^itsOwner bounds]. "handles every plausible situation" ^self paintArea! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nk 7/7/2003 11:15'! patchAt: patchRect without: stopMorph andNothingAbove: stopThere "Return a complete rendering of this patch of the display screen without stopMorph, and possibly without anything above it." | c | c _ ColorPatchCanvas extent: patchRect extent depth: Display depth origin: patchRect topLeft negated clipRect: (0@0 extent: patchRect extent). c stopMorph: stopMorph. c doStop: stopThere. (self bounds containsRect: patchRect) ifFalse: ["Need to fill area outside bounds with black." c form fillColor: Color black]. (self bounds intersects: patchRect) ifFalse: ["Nothing within bounds to show." ^ c form]. self fullDrawOn: c. stopThere ifFalse: [ self world handsReverseDo: [:h | h drawSubmorphsOn: c]]. ^c form ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! previousPage "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful" Beeper beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 2/7/2002 16:22'! repositionFlapsAfterScreenSizeChange "Reposition flaps after screen size change" (Flaps globalFlapTabsIfAny, ActiveWorld localFlapTabs) do: [:aFlapTab | aFlapTab applyEdgeFractionWithin: self bounds]. Flaps doAutomaticLayoutOfFlapsIfAppropriate! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 3/18/2001 00:35'! restoreDisplay World restoreMorphicDisplay. "I don't actually expect this to be called"! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 8/31/2004 16:25'! restoreFlapsDisplay "Restore the display of flaps" (Flaps sharedFlapsAllowed and: [CurrentProjectRefactoring currentFlapsSuppressed not]) ifTrue: [Flaps globalFlapTabs do: [:aFlapTab | aFlapTab adaptToWorld]]. self localFlapTabs do: [:aFlapTab | aFlapTab adaptToWorld]. self assureFlapTabsFitOnScreen. self bringTopmostsToFront! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 12/30/2004 00:59'! restoreMorphicDisplay "Restore the morphic display -- initiated by explicit user request" DisplayScreen startUp. ThumbnailMorph recursionReset. self extent: Display extent; viewBox: Display boundingBox; handsDo: [:h | h visible: true; showTemporaryCursor: nil]; restoreFlapsDisplay; fullRepaintNeeded. WorldState addDeferredUIMessage: [Cursor normal show]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:11'! someHalo "Return some halo that's currently visible in the world" | m | ^(m := self haloMorphs) notEmpty ifTrue: [m first] ifFalse: [nil]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! standardPlayerHit self playSoundNamed: 'peaks'. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'dgd 2/22/2003 14:12'! standardSystemController ^ScheduledControllers controllerSatisfying: [:c | c view subViews notEmpty and: [c view firstSubView model == self]]! ! !PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'! privateRemoveMorph: aMorph backgroundMorph == aMorph ifTrue: [ backgroundMorph _ nil ]. ^super privateRemoveMorph: aMorph. ! ! !PasteUpMorph methodsFor: 'name' stamp: 'sw 6/17/2004 01:46'! unusedMorphNameLike: stem "Answer a suitable name for a morph in this world, based on the stem provided" | names | names _ self allKnownNames. ^ Utilities keyLike: stem asString satisfying: [:aName | (names includes: aName) not]! ! !PasteUpMorph methodsFor: '*flexiblevocabularies-scripting' stamp: 'nk 8/21/2004 13:35'! printVocabularySummary "Put up a window with summaries of all Morph vocabularies." (StringHolder new contents: EToyVocabulary vocabularySummary) openLabel: 'EToy Vocabulary' "self currentWorld printVocabularySummary"! ! !PasteUpMorph methodsFor: '*customevents-scripting' stamp: 'nk 9/26/2003 23:24'! addUserCustomEventNamed: aSymbol help: helpString self userCustomEventsRegistry at: aSymbol put: helpString. ! ! !PasteUpMorph methodsFor: '*customevents-scripting' stamp: 'nk 9/26/2003 23:26'! removeUserCustomEventNamed: aSymbol ^self userCustomEventsRegistry removeKey: aSymbol ifAbsent: [].! ! !PasteUpMorph methodsFor: '*customevents-scripting' stamp: 'nk 9/26/2003 23:20'! userCustomEventNames | reg | reg _ self valueOfProperty: #userCustomEventsRegistry ifAbsent: [ ^#() ]. ^reg keys asArray sort! ! !PasteUpMorph methodsFor: '*customevents-scripting' stamp: 'nk 9/26/2003 23:18'! userCustomEventsRegistry ^self valueOfProperty: #userCustomEventsRegistry ifAbsentPut: [ IdentityDictionary new ].! ! !PasteUpMorph methodsFor: '*standardyellowbuttonmenus-event handling' stamp: 'nk 1/23/2004 16:29'! hasYellowButtonMenu ^self isWorldMorph ! ! !PasteUpMorph methodsFor: '*standardyellowbuttonmenus-misc' stamp: 'nk 1/23/2004 16:25'! addMyYellowButtonMenuItemsToSubmorphMenus ^self isPartsBin! ! !PasteUpMorph commentStamp: '<historical>' prior: 0! A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Anything called a 'Playfield' is a PasteUpMorph. Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. presenter A Presenter in charge of stopButton stepButton and goButton, mouseOverHalosEnabled soundsEnabled fenceEnabled coloredTilesEnabled. model <not used> cursor ?? padding ?? backgroundMorph A Form that covers the background. turtleTrailsForm Moving submorphs may leave trails on this form. turtlePen Draws the trails. lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn only once each step cycle. The point is the start of the current stroke. isPartsBin If true, every object dragged out is copied. autoLineLayout ?? indicateCursor ?? resizeToFit ?? wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo. worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. griddingOn If true, submorphs are on a grid ! !PasteUpMorph class methodsFor: 'class initialization' stamp: 'nk 12/13/2004 18:22'! initialize "Initialize the class" self registerInFlapsRegistry. ScriptingSystem addCustomEventFor: self named: #keyStroke help: 'when a keystroke happens and nobody heard it' targetMorphClass: PasteUpMorph.! ! !PasteUpMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:10'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') forFlapNamed: 'Supplies'. cl registerQuad: #(PasteUpMorph authoringPrototype 'Playfield' 'A place for assembling parts or for staging animations') forFlapNamed: 'Scripting']! ! !PasteUpMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !PasteUpMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:48'! descriptionForPartsBin ^ self partName: 'Playfield' categories: #('Presentation') documentation: 'A place for assembling parts or for staging animations'! ! !PasteUpMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 16:29'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'Holder' categoryList: #(Scripting) documentation: 'A place for storing alternative pictures in an animation, ec.' globalReceiverSymbol: #ScriptingSystem nativitySelector: #prototypicalHolder}! ! !PasteUpMorph class methodsFor: 'scripting' stamp: 'sw 10/3/2004 01:14'! additionsToViewerCategories "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ # ( (playfield ( (command initiatePainting 'Initiate painting of a new object in the standard playfield.') (slot mouseX 'The x coordinate of the mouse pointer' Number readWrite Player getMouseX unused unused) (slot mouseY 'The y coordinate of the mouse pointer' Number readWrite Player getMouseY unused unused) (command roundUpStrays 'Bring all out-of-container subparts back into view.') (slot graphic 'The graphic shown in the background of this object' Graphic readWrite Player getGraphic Player setGraphic:) (command unhideHiddenObjects 'Unhide all hidden objects.'))) (scripting ( (command tellAllContents: 'Send a message to all the objects inside the playfield' ScriptName))) (collections ( (slot cursor 'The index of the chosen element' Number readWrite Player getCursor Player setCursorWrapped:) (slot count 'How many elements are within me' Number readOnly Player getCount unused unused) (slot stringContents 'The characters of the objects inside me, laid end to end' String readOnly Player getStringContents unused unused) (slot playerAtCursor 'the object currently at the cursor' Player readWrite Player getValueAtCursor unused unused) (slot firstElement 'The first object in my contents' Player readWrite Player getFirstElement Player setFirstElement:) (slot numberAtCursor 'the number at the cursor' Number readWrite Player getNumberAtCursor Player setNumberAtCursor: ) (slot graphicAtCursor 'the graphic worn by the object at the cursor' Graphic readOnly Player getGraphicAtCursor unused unused) (command tellAllContents: 'Send a message to all the objects inside the playfield' ScriptName) (command removeAll 'Remove all elements from the playfield') (command shuffleContents 'Shuffle the contents of the playfield') (command append: 'Add the object to the end of my contents list.' Player) (command prepend: 'Add the object at the beginning of my contents list.' Player) (command includeAtCursor: 'Add the object to my contents at my current cursor position' Player) (command include: 'Add the object to my contents' Player) )) (#'stack navigation' ( (command goToNextCardInStack 'Go to the next card') (command goToPreviousCardInStack 'Go to the previous card') (command goToFirstCardInBackground 'Go to the first card of the current background') (command goToFirstCardOfStack 'Go to the first card of the entire stack') (command goToLastCardInBackground 'Go to the last card of the current background') (command goToLastCardOfStack 'Go to the last card of the entire stack') (command deleteCard 'Delete the current card') (command insertCard 'Create a new card'))) "(viewing ( (slot viewingNormally 'whether contents are viewed normally' Boolean readWrite Player getViewingByIcon Player setViewingByIcon: )))" (#'pen trails' ( (command liftAllPens 'Lift the pens on all the objects in my interior.') (command lowerAllPens 'Lower the pens on all the objects in my interior.') (command trailStyleForAllPens: 'Set the trail style for pens of all objects within' TrailStyle) (command clearTurtleTrails 'Clear all the pen trails in the interior.')))) ! ! !PasteUpMorph class methodsFor: 'scripting' stamp: 'nk 10/13/2004 11:39'! additionsToViewerCategoryInput "Answer a list of (<categoryName> <list of category specs>) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #(input ( (slot lastKeystroke 'The last unhandled keystroke' String readWrite Player getLastKeystroke Player setLastKeystroke:) ))! ! !PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! shutDown World ifNotNil:[ World triggerEvent: #aboutToLeaveWorld. ].! ! !PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! startUp World ifNotNil:[ World restoreMorphicDisplay. World triggerEvent: #aboutToEnterWorld. ].! ! !PasteUpMorphTest methodsFor: 'texture fills' stamp: 'mjr 3/6/2003 11:34'! testGridToGradient "A trivial test for checking that you can change from a grid to a gradient background. A recent [FIX] will make this pass." | pum | pum _ PasteUpMorph new. pum setStandardTexture. "The following should fail without the fix" self shouldnt: [pum gradientFillColor: Color red] raise: MessageNotUnderstood! ! !PasteUpMorphTest methodsFor: 'cursor' stamp: 'tak 11/7/2004 18:29'! testCursorWrapped "self debug: #testCursorWrapped" | holder | holder := PasteUpMorph new. self assert: holder cursor = 1. holder cursorWrapped: 2. self assert: holder cursor = 1. holder addMorph: Morph new; addMorph: Morph new; addMorph: Morph new. holder cursorWrapped: 3. self assert: holder cursor = 3. holder cursorWrapped: 5. self assert: holder cursor = 2. holder cursorWrapped: 0. self assert: holder cursor = 3. holder cursorWrapped: -1. self assert: holder cursor = 2.! ! !PasteUpMorphTest methodsFor: 'cursor' stamp: 'tak 11/7/2004 18:34'! testCursorWrappedWithFraction "self debug: #testCursorWrappedWithFraction" | holder | holder := PasteUpMorph new. holder addMorph: Morph new; addMorph: Morph new; addMorph: Morph new. holder cursorWrapped: 3.5. self assert: holder cursor = 3.5. holder cursorWrapped: 5.5. self assert: holder cursor = 2.5. holder cursorWrapped: 0.5. self assert: holder cursor = 3.5. holder cursorWrapped: -0.5. self assert: holder cursor = 2.5.! ! !PasteUpMorphTest commentStamp: '<historical>' prior: 0! I am a TestCase for PasteUpMorph.! !Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 03:17'! arrowHead "Put an arrowhead on the previous pen stroke" " | pen | pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHead]." penDown ifTrue: [self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location to: location arrowSpec: (Preferences parameterAt: #arrowSpec ifAbsent: [5 @ 4])]! ! !Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:29'! arrowHeadForArrowSpec: anArrowSpec "Put an arrowhead on the previous pen stroke" " | pen aPoint | aPoint _ Point fromUser. pen _ Pen new. 20 timesRepeat: [pen turn: 360//20; go: 20; arrowHeadForArrowSpec: aPoint]. " penDown ifTrue: [self arrowHeadFrom: (direction degreeCos @ direction degreeSin) * -40 + location to: location arrowSpec: anArrowSpec]! ! !Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:25'! arrowHeadFrom: prevPt to: newPt arrowSpec: anArrowSpec "Put an arrowhead on the pen stroke from oldPt to newPt" | pm af myColor finalPt delta | myColor _ self color. delta _ newPt - prevPt. delta r <= 2 "pixels" ifTrue: [^ self]. finalPt _ newPt + (Point r: sourceForm width degrees: delta degrees). "in same direction" pm _ PolygonMorph vertices: (Array with: prevPt asIntegerPoint with: finalPt asIntegerPoint) color: myColor "not used" borderWidth: sourceForm width borderColor: myColor. pm makeOpen; makeForwardArrow. anArrowSpec ifNotNil: [pm arrowSpec: anArrowSpec]. af _ pm arrowForms first. "render it onto the destForm" (FormCanvas on: destForm "Display") stencil: af at: af offset + (1@1) color: myColor! ! !Pen methodsFor: 'operations' stamp: 'sw 10/5/2002 02:11'! arrowHeadFrom: prevPt to: newPt forPlayer: aPlayer "Put an arrowhead on the pen stroke from oldPt to newPt" | aSpec | (aPlayer notNil and: [(aSpec _ aPlayer costume renderedMorph valueOfProperty: #arrowSpec) notNil]) ifFalse: [aSpec _ Preferences parameterAt: #arrowSpec "may well be nil"]. self arrowHeadFrom: prevPt to: newPt arrowSpec: aSpec! ! !Pen methodsFor: 'operations' stamp: 'sw 4/10/2003 22:37'! putDotOfDiameter: aDiameter at: aPoint "Put a dot of the given size at the given point, using my colot" (FormCanvas on: destForm) fillOval: (Rectangle center: aPoint extent: (aDiameter @ aDiameter)) color: self color! ! !Pen methodsFor: 'operations'! up "Set the state of the receiver's pen to up (no drawing)." penDown _ false! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'ar 5/14/2001 23:35'! feltTip: width cellSize: cellSize "Warning: This example potentially uses a large amount of memory--it creates a Form with cellSize squared bits for every Display pixel." "In this example, all drawing is done into a large, monochrome Form and then scaled down onto the Display using smoothing. The larger the cell size, the more possible shades of gray can be generated, and the smoother the resulting line appears. A cell size of 8 yields 64 possible grays, while a cell size of 16 gives 256 levels, which is about the maximum number of grays that the human visual system can distinguish. The width parameter determines the maximum line thickness. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." "Pen feltTip: 2.7 cellSize: 8" | tabletScale bitForm pen warp p srcR dstR nibSize startP r | tabletScale _ self tabletScaleFactor. bitForm _ Form extent: Display extent * cellSize depth: 1. pen _ Pen newOnForm: bitForm. pen color: Color black. warp _ (WarpBlt current toForm: Display) sourceForm: bitForm; colorMap: (bitForm colormapIfNeededFor: Display); cellSize: cellSize; combinationRule: Form over. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ p _ (Sensor tabletPoint * cellSize * tabletScale) rounded. nibSize _ (Sensor tabletPressure * (cellSize * width)) rounded. nibSize > 0 ifTrue: [ pen squareNib: nibSize. startP _ pen location. pen goto: p. r _ startP rect: pen location. dstR _ (r origin // cellSize) corner: ((r corner + nibSize + (cellSize - 1)) // cellSize). srcR _ (dstR origin * cellSize) corner: (dstR corner * cellSize). warp copyQuad: srcR innerCorners toRect: dstR] ifFalse: [ pen place: p]]]. ! ! !PenPointRecorder methodsFor: 'line drawing' stamp: 'md 11/14/2003 16:56'! drawFrom: p1 to: p2 "Overridden to skip drawing but track bounds of the region traversed." points ifNil: [points _ OrderedCollection with: p1]. points addLast: p2! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:02'! changePhonemeDetails "Change the name and mouth position index of a phoneme specified by the user." | phoneme | phoneme _ self selectPhonemeFromMenu: 'Phoneme to rename'. phoneme ifNotNil: [self promptForDetailsOfPhoneme: phoneme]. ! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:03'! deletePhoneme "Delete a phoneme specified by the user." | phoneme | phoneme _ self selectPhonemeFromMenu: 'Phoneme to delete'. phoneme ifNotNil: [ phonemeRecords remove: phoneme ifAbsent: []]. ! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'sw 9/26/2001 03:23'! makeTile "Make a scripting tile to fetch the current phoneme's mouth position. Attach it to the hand, allowing the user to drop it directly into a tile script." | tile argTile | tile _ PhraseTileMorph new setSlotRefOperator: #mouthPosition type: #Number. argTile _ self tileToRefer. argTile bePossessive. tile firstSubmorph addMorph: argTile. tile enforceTileColorPolicy. ActiveHand attachMorph: tile ! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:03'! playPhoneme "Play a phoneme specified by the user." | phoneme | phoneme _ self selectPhonemeFromMenu: 'Phoneme to play'. phoneme ifNotNil: [phoneme play]. ! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dgd 2/22/2003 13:46'! readPhonemes "Read a previously saved phoneme set from a file." | fname s newPhonemes | fname := Utilities chooseFileWithSuffixFromList: #('.pho' '.phonemes') withCaption: 'Phoneme file?'. fname isNil ifTrue: [^self]. fname ifNil: [^self]. s := FileStream readOnlyFileNamed: fname. newPhonemes := s fileInObjectAndCode. s close. phonemeRecords := newPhonemes! ! !PhonemeRecognizerMorph methodsFor: 'button and menu commands' stamp: 'dns 2/28/2001 14:04'! showPhonemeFeatures "Show a graph of the features array for the phoneme selected by the user." | phoneme m | phoneme _ self selectPhonemeFromMenu: 'Show Features'. phoneme ifNotNil: [ m _ ImageMorph new image: phoneme featuresGraph. self world firstHand attachMorph: m]. ! ! !PhonemeRecognizerMorph methodsFor: 'private' stamp: 'nk 7/12/2003 08:59'! addTitle "Add a title." | font title r | font _ StrikeFont familyName: Preferences standardEToysFont familyName size: 20. title _ StringMorph contents: 'Phoneme Recognizer' font: font. r _ AlignmentMorph newColumn color: color; layoutInset: 0; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #spaceFill; vResizing: #rigid; height: 20. r addMorphBack: title. self addMorphBack: r. self addMorphBack: (Morph new extent: 5@8; color: Color transparent). "spacer" ! ! !PhonemeRecognizerMorph methodsFor: 'private' stamp: 'dns 2/28/2001 14:01'! selectPhonemeFromMenu: title "Answer the phone selected by the user from a menu of the current phoneme records. Answer nil if the user does not select any phoneme." | aMenu | phonemeRecords isEmpty ifTrue: [self inform: 'The phoneme database is empty.'. ^ nil]. aMenu _ CustomMenu new title: title. phonemeRecords do: [:phoneme | aMenu add: phoneme name action: phoneme]. ^ aMenu startUp ! ! !PhoneticRule methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:08'! = anObject self species == anObject species ifFalse: [^ false]. ^ anObject left = self left and: [anObject right = self right and: [anObject text = self text and: [anObject phonemes = self phonemes]]]! ! !PhoneticRule methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:09'! species ^PhoneticRule ! ! !PhoneticTranscriber class methodsFor: 'examples' stamp: 'len 8/24/2001 13:48'! englishLexicon ^ Dictionary new add: 'HOW' -> 'HH AW1'; add: 'YOU' -> 'Y UW1'; add: 'ARE' -> 'AA1 R'; add: 'DOING' -> 'D UW1 IH0 NG'; add: 'THIS' -> 'DH IH1 S'; add: 'IS' -> 'IH1 Z'; add: 'MY' -> 'M AY1'; add: 'HI' -> 'HH AY1'; add: 'VOICE' -> 'V OY1 S'; add: 'FAST' -> 'F AE1 S T'; add: 'SLOW' -> 'S L OW1'; add: 'I' -> 'AY1'; add: 'AM' -> 'AE1 M'; add: 'A' -> 'AH0'; add: 'AN' -> 'AE1 N'; add: 'LOW' -> 'L OW1'; add: 'SPEAKER' -> 'S P IY1 K ER0'; add: 'ANSWER' -> 'AE1 N S ER0'; add: 'RECEIVER' -> 'R AH0 S IY1 V ER0'; add: 'OBJECT' -> 'AA1 B JH EH0 K T'; add: 'READ' -> 'R IY1 D'; add: 'WRITE' -> 'R AY1 T'; add: 'SQUEAK' -> 'S K W IY1 K'; add: 'SMALLTALK' -> ' S M AO1 L T AO2 K'; add: 'CLASS' -> 'K L AE1 S'; add: 'WOMAN' -> 'W UH1 M AH0 N'; add: 'BICYCLIC' -> 'B AY1 S IH0 K L IH0 K'; add: 'LISTEN' -> 'L IH1 S AH0 N'; add: 'ZERO' -> 'Z IY1 R OW'; add: 'SEVEN' -> 'S EH1 V EH N'; add: 'ELEVEN' -> 'EH1 L EH1 V EH N'; add: 'SEVENTEEN' -> 'S EH1 V EH N T IY N'; add: 'SEVENTY' -> 'S EH1 V EH N T IH'; add: 'NINETEEN' -> 'N AH1 N T IY N'; add: 'NINETY' -> 'N AH1 N T IH'; yourself! ! !PhraseTileMorph methodsFor: 'all' stamp: 'sw 12/13/2001 17:41'! rowOfRightTypeFor: aLayoutMorph forActor: aPlayer "Answer a phrase of the right type for the putative container" | aTemporaryViewer aPhrase | aLayoutMorph demandsBoolean ifTrue: [self isBoolean ifTrue: [^ self]. aTemporaryViewer _ CategoryViewer new invisiblySetPlayer: aPlayer. aPhrase _ aTemporaryViewer booleanPhraseFromPhrase: self. aPhrase justGrabbedFromViewer: false. ^ aPhrase]. ^ self! ! !PhraseTileMorph methodsFor: 'code generation' stamp: 'dgd 2/22/2003 19:08'! storeCodeOn: aStream indent: tabCount "Add in some smarts for division by zero." aStream nextPut: $(. submorphs first storeCodeOn: aStream indent: tabCount. aStream space. submorphs second storeCodeOn: aStream indent: tabCount. submorphs size > 2 ifTrue: [(self catchDivideByZero: aStream indent: tabCount) ifFalse: [aStream space. (submorphs third) storeCodeOn: aStream indent: tabCount]]. aStream nextPut: $)! ! !PhraseTileMorph methodsFor: 'dropping/grabbing' stamp: 'sw 2/9/2001 00:15'! justDroppedInto: newOwner event: evt "Phrase tiles only auto-expand if they originate from viewers. Any phrase tile, once dropped, loses its auto-phrase-expansion thing" justGrabbedFromViewer _ false. super justDroppedInto: newOwner event: evt! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 8/28/2004 14:23'! initialize "Initialize a nascent instance" super initialize. resultType _ #unknown. brightenedOnEnter _ false. self wrapCentering: #center; cellPositioning: #leftCenter. self hResizing: #shrinkWrap. borderWidth _ 0. self layoutInset: 0. self extent: 5@5. "will grow to fit" self minCellSize: (0 @ (Preferences standardEToysFont height rounded + 10)). justGrabbedFromViewer _ true. "All new PhraseTileMorphs that go through the initialize process (rather than being copied) are placed in viewers; the clones dragged out from them will thus have this set the right way; the drop code resets this to false" ! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 8/12/2004 18:58'! setAssignmentRoot: opSymbol type: opType rcvrType: rcvrType argType: argType vocabulary: aVocabulary "Add submorphs to make me constitute a setter of the given symbol" | anAssignmentTile | resultType _ opType. self color: (ScriptingSystem colorForType: opType). self removeAllMorphs. self addMorph: (TilePadMorph new setType: rcvrType). anAssignmentTile _ AssignmentTileMorph new rawVocabulary: aVocabulary. self addMorphBack: (anAssignmentTile typeColor: color). anAssignmentTile setRoot: opSymbol asString dataType: argType. anAssignmentTile setAssignmentSuffix: #:. self addMorphBack: (TilePadMorph new setType: argType)! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 9/26/2001 11:58'! setOperator: opSymbol type: opType rcvrType: rcvrType argType: argType "Set the operator, type, receiver type, and argument type for the phrase" | aTileMorph | resultType _ opType. opType ifNotNil: [self color: (ScriptingSystem colorForType: opType)]. self removeAllMorphs. self addMorph: (TilePadMorph new setType: rcvrType). aTileMorph _ TileMorph new adoptVocabulary: self currentVocabulary. self addMorphBack: ((aTileMorph setOperator: opSymbol asString) typeColor: color). opSymbol numArgs = 1 ifTrue: [self addMorphBack: (TilePadMorph new setType: (argType ifNil: [#Object]))]! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:41'! setSlotRefOperator: opSymbol type: opType "Set the given symbol as the receiver's slot-reference operator, adding tiles to the receiver appropriately" resultType _ opType. self color: (ScriptingSystem colorForType: opType). self removeAllMorphs. self addMorph: (TilePadMorph new setType: #Player). self addMorphBack: ((TileMorph new setSlotRefOperator: opSymbol asString) typeColor: color) ! ! !PhraseTileMorph methodsFor: 'initialization' stamp: 'gm 2/24/2003 18:06'! vocabulary: aVocab "Set the vocabulary" vocabularySymbol := (aVocab isKindOf: Symbol) ifTrue: [aVocab] ifFalse: [aVocab vocabularyName]! ! !PhraseTileMorph methodsFor: 'macpal' stamp: 'sw 6/4/2001 19:35'! currentVocabulary "Answer the current vocabulary" vocabulary "fix up old strutures" ifNotNil: [vocabularySymbol _ vocabulary vocabularyName. vocabulary _ nil]. ^ vocabularySymbol ifNotNil: [Vocabulary vocabularyNamed: vocabularySymbol] ifNil: [super currentVocabulary] ! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: aMenu hand: aHand "Add additional items to the halo manu" super addCustomMenuItems: aMenu hand: aHand. aMenu add: 'Sprout a new scriptor around this phrase' translated target: self action: #sproutNewScriptor! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 12/22/2004 01:34'! dismissViaHalo "The user has clicked in the delete halo-handle.." | ed | ed _ self topEditor. super dismissViaHalo. ed ifNotNil: [ed scriptEdited]! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 3/7/2004 13:04'! isPlayer: aPlayer ofReferencingTile: tile "Answer whether a given player is the object referred to by the given tile, or a sibling of that object." ^ aPlayer class == self actualObject class! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'sw 9/27/2001 17:28'! resultType "Answer the result type of the receiver" ^ resultType! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/14/2001 14:07'! sproutNewScriptor "The receiver, operating as a naked phrase tile, wishes to get iself placed in a nascent script" | newScriptor | self actualObject assureUniClass. newScriptor _ self actualObject newScriptorAround: ((self ownerThatIsA: Viewer orA: ScriptEditorMorph) ifNotNil: [self veryDeepCopy] ifNil: [self]). self currentHand attachMorph: newScriptor! ! !PhraseTileMorph methodsFor: 'miscellaneous' stamp: 'tk 2/15/2001 16:37'! tileRows "Answer a list of tile rows -- in this case exactly one row -- representing the receiver. The fullCopy is deeply problematical here in the presence of the formerOwner property, so it the latter is temporarily set aside" ^ Array with: (Array with: self veryDeepCopy)! ! !PhraseTileMorph methodsFor: 'mouse' stamp: 'tak 3/15/2005 11:40'! catchDivideByZero: aStream indent: tabCount "See if I am have divide as my operator. If so, insert a test in the argument to divide." | exp | submorphs second type = #operator ifFalse: [^false]. "not me" exp _ submorphs second operatorOrExpression. (#(/ // \\) includes: exp) ifFalse: [^false]. "not me" aStream space. aStream nextPutAll: '(self beNotZero: '. (submorphs third) storeCodeOn: aStream indent: tabCount. aStream nextPut: $). ^true! ! !PhraseTileMorph methodsFor: 'mouse' stamp: 'sw 1/6/2005 04:34'! morphToDropInPasteUp: aPasteUp "Answer the morph to drop in aPasteUp, given that the receiver is the putative droppee" | actualObject itsSelector aScriptor pos aWatcher op | ((actualObject _ self actualObject) isNil or: [actualObject costume isInWorld not]) ifTrue: [^ self]. self isCommand ifFalse: "Can't expand to a scriptor, but maybe launch a watcher..." [^ (Preferences dropProducesWatcher and: [(#(unknown command) includes: self resultType) not] and: [(op _ self operatorTile operatorOrExpression) notNil] and: [op numArgs = 0] and: [(Vocabulary gettersForbiddenFromWatchers includes: op) not]) ifTrue: [aWatcher _ self associatedPlayer fancyWatcherFor: op. aWatcher position: self position] ifFalse: [self]]. self justGrabbedFromViewer ifFalse: [^ self]. actualObject assureUniClass. itsSelector _ self userScriptSelector. pos _ self position. aScriptor _ itsSelector isEmptyOrNil ifFalse: [actualObject scriptEditorFor: itsSelector] ifTrue: ["It's a system-defined selector; construct an anonymous scriptor around it" actualObject newScriptorAround: self]. aScriptor ifNil:[^self]. (self hasOwner: aScriptor) ifTrue:[ aScriptor fullBounds. "force layout" aScriptor position: pos - self position. ] ifFalse:[ aScriptor position: self position. ]. ^ aScriptor! ! !PhraseTileMorph methodsFor: 'mouse' stamp: 'sw 6/17/2003 16:03'! mouseDown: evt "Handle a mouse-down on the receiver" | ed guyToTake dup enclosingPhrase | self isPartsDonor ifTrue: [dup _ self duplicate. dup eventHandler: nil. "Remove viewer-related evt mouseover feedback" evt hand attachMorph: dup. dup position: evt position. "So that the drag vs. click logic works" dup formerPosition: evt position. ^ self]. submorphs isEmpty ifTrue: [^ self]. guyToTake _ self. [(enclosingPhrase _ guyToTake ownerThatIsA: PhraseTileMorph) notNil] whileTrue: [guyToTake _ enclosingPhrase]. "This logic always grabs the outermost phrase, for now anyway" "the below had comment: 'picking me out of another phrase'" "owner class == TilePadMorph ifTrue: [(ss _ submorphs first) class == TilePadMorph ifTrue: [ss _ ss submorphs first]. guyToTake _ ss veryDeepCopy]." (ed _ self enclosingEditor) ifNil: [^ evt hand grabMorph: guyToTake]. evt hand grabMorph: guyToTake. ed startStepping. ed mouseEnterDragging: evt. ed setProperty: #justPickedUpPhrase toValue: true. ! ! !PhraseTileMorph methodsFor: 'queries' stamp: 'sw 9/28/2001 07:46'! isBoolean "Answer whether the receiver has a boolean type" ^ self resultType = #Boolean! ! !PhraseTileMorph methodsFor: '*customevents-scripting' stamp: 'nk 11/1/2004 11:14'! setAsActionInButtonProperties: buttonProperties userScriptSelector ifNil: [ buttonProperties target: self associatedPlayer; actionSelector: #evaluateUnloggedForSelf:; arguments: {self codeString}. ^true ]. buttonProperties target: self objectViewed player; actionSelector: #triggerScript: ; arguments: {userScriptSelector}. ^true "==== or buttonProperties target: (self morphToDropInPasteUp: nil); actionSelector: #tryMe; arguments: #(). ^true ==="! ! !PhraseTileMorph methodsFor: '*customevents-scripting' stamp: 'nk 11/1/2004 11:08'! try "Evaluate the given phrase once" | aPlayer | (userScriptSelector notNil and: [userScriptSelector numArgs = 0]) ifTrue: [aPlayer _ self objectViewed player. aPlayer triggerScript: userScriptSelector] ifFalse: [Compiler evaluate: self codeString for: self associatedPlayer logged: false]! ! !PhraseTileMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'! defaultNameStemForInstances ^ 'PhraseTile'! ! !PianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !PianoKeyboardMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:56'! initialize "initialize the state of the receiver" super initialize. "" whiteKeyColor _ Color gray: 0.95. blackKeyColor _ Color black. playingKeyColor _ Color red. nOctaves _ 6. self buildKeyboard. soundPrototype _ FMSound brass1 duration: 9.9! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:30'! buildKeyboard | wtWid bkWid keyRect octavePt nWhite nBlack | self removeAllMorphs. wtWid _ 8. bkWid _ 5. self extent: 10@10. 1 to: nOctaves+1 do: [:i | i <= nOctaves ifTrue: [nWhite _ 7. nBlack _ 5] ifFalse: [nWhite _ 1. nBlack _ 0 "High C"]. octavePt _ self innerBounds topLeft + ((7*wtWid*(i-1)-1)@-1). 1 to: nWhite do: [:j | keyRect _ octavePt + (j-1*wtWid@0) extent: (wtWid+1)@36. self addMorph: ((RectangleMorph newBounds: keyRect color: whiteKeyColor) borderWidth: 1; on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self withValue: i-1*12 + (#(1 3 5 6 8 10 12) at: j))]. 1 to: nBlack do: [:j | keyRect _ octavePt + ((#(6 15 29 38 47) at: j)@1) extent: bkWid@21. self addMorph: ((Morph newBounds: keyRect color: blackKeyColor) on: #mouseDown send: #mouseDownPitch:event:noteMorph: to: self withValue: i-1*12 + (#(2 4 7 9 11) at: j))]]. self submorphsDo: [:m | m on: #mouseMove send: #mouseMovePitch:event:noteMorph: to: self; on: #mouseUp send: #mouseUpPitch:event:noteMorph: to: self; on: #mouseEnterDragging send: #mouseDownPitch:event:noteMorph: to: self; on: #mouseLeaveDragging send: #mouseUpPitch:event:noteMorph: to: self]. self extent: (self fullBounds extent + borderWidth - 1)! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:27'! mouseDownEvent: arg1 noteMorph: arg2 pitch: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self mouseDownPitch: arg1 event: arg2 noteMorph: arg3! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:27'! mouseDownPitch: midiKey event: event noteMorph: noteMorph | pitch | event hand hasSubmorphs ifTrue: [^ self "no response if drag something over me"]. event hand mouseFocus ifNil: ["If dragged into me, then establish focus so I'll see moves" event hand newMouseFocus: noteMorph event: event]. noteMorph color: playingKeyColor. pitch _ AbstractSound pitchForMIDIKey: midiKey + 23. soundPlaying ifNotNil: [soundPlaying stopGracefully]. soundPlaying _ soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3. SoundPlayer resumePlaying: soundPlaying quickStart: true. ! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:27'! mouseMoveEvent: arg1 noteMorph: arg2 pitch: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self mouseMovePitch: arg1 event: arg2 noteMorph: arg3! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:28'! mouseMovePitch: pitch event: event noteMorph: noteMorph (noteMorph containsPoint: event cursorPoint) ifFalse: ["If drag out of me, zap focus so other morphs can see drag in." event hand releaseMouseFocus: noteMorph] ! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/18/2001 17:28'! mouseUpEvent: arg1 noteMorph: arg2 pitch: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self mouseUpPitch: arg1 event: arg2 noteMorph: arg3! ! !PianoKeyboardMorph methodsFor: 'simple keyboard' stamp: 'ar 3/17/2001 14:29'! mouseUpPitch: pitch event: event noteMorph: noteMorph noteMorph color: ((#(0 1 3 5 6 8 10) includes: pitch\\12) ifTrue: [whiteKeyColor] ifFalse: [blackKeyColor]). soundPlaying ifNotNil: [soundPlaying stopGracefully]. ! ! !PianoKeyboardMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 14:52'! descriptionForPartsBin ^ self partName: 'PianoKeyboard' categories: #('Multimedia') documentation: 'A piano keyboard'! ! !PianoRollNoteMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 14:49'! mouseMove: evt | delta offsetEvt | editMode isNil ifTrue: ["First movement determines edit mode" ((delta := evt cursorPoint - hitLoc) dist: 0 @ 0) <= 2 ifTrue: [^self "No significant movement yet."]. delta x abs > delta y abs ifTrue: [delta x > 0 ifTrue: ["Horizontal drag" editMode := #selectNotes] ifFalse: [self playSound: nil. offsetEvt := evt copy setCursorPoint: evt cursorPoint + (20 @ 0). self invokeNoteMenu: offsetEvt]] ifFalse: [editMode := #editPitch "Vertical drag"]]. editMode == #editPitch ifTrue: [self editPitch: evt]. editMode == #selectNotes ifTrue: [self selectNotes: evt]! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'jm 6/1/2001 01:29'! soundOfDuration: duration | sound | sound _ MixedSound new. sound add: (self noteOfDuration: duration) pan: (owner scorePlayer panForTrack: trackIndex) volume: owner scorePlayer overallVolume * (owner scorePlayer volumeForTrack: trackIndex). ^ sound reset ! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'dgd 2/22/2003 14:50'! selectFrom: selection (trackIndex = selection first and: [indexInTrack >= (selection second) and: [indexInTrack <= (selection third)]]) ifTrue: [selected ifFalse: [self select]] ifFalse: [selected ifTrue: [self deselect]]! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'! copySelection selection isNil ifTrue: [^self]. NotePasteBuffer := (score tracks at: selection first) copyFrom: selection second to: selection third! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'! cutSelection selection isNil ifTrue: [^self]. self copySelection. self deleteSelection! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'! deleteSelection | selMorphs priorEvent x | (selection isNil or: [selection second = 0]) ifTrue: [^self]. score cutSelection: selection. selection second > 1 ifTrue: [selection at: 2 put: selection second - 1. selection at: 3 put: selection second. priorEvent := (score tracks at: selection first) at: selection second. (x := self xForTime: priorEvent time) < (self left + 30) ifTrue: [self autoScrollForX: x - ((30 + self width) // 4)]] ifFalse: [selection := nil]. scorePlayer updateDuration. self rebuildFromScore. selMorphs := self submorphsSatisfying: [:m | (m isKindOf: PianoRollNoteMorph) and: [m selected]]. selMorphs isEmpty ifFalse: [(selMorphs last noteOfDuration: 0.3) play]! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'! insertSelection self selection isNil ifTrue: [^self]. score insertEvents: NotePasteBuffer at: self selection. scorePlayer updateDuration. self rebuildFromScore! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'dgd 2/21/2003 22:56'! insertTransposed | delta transposedNotes | (delta := (SelectionMenu selections: ((12 to: -12 by: -1) collect: [:i | i printString])) startUpWithCaption: 'offset...') ifNil: [^self]. transposedNotes := NotePasteBuffer collect: [:note | note copy midiKey: note midiKey + delta]. selection isNil ifTrue: [^self]. score insertEvents: transposedNotes at: self selection. scorePlayer updateDuration. self rebuildFromScore! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'jm 6/1/2001 01:30'! mouseDown: evt | noteMorphs chordRect sound | (self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 2@30)) isEmpty ifTrue: ["If not near a note, then put up score edit menu" ^ self invokeScoreMenu: evt]. "Clicked near (but not on) a note, so play all notes at the cursor time" noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height). chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1. soundsPlayingMorph _ Morph newBounds: chordRect color: Color green. self addMorphBack: soundsPlayingMorph. soundsPlaying _ IdentityDictionary new. noteMorphs do: [:m | sound _ m soundOfDuration: 999.0. soundsPlaying at: m put: sound. SoundPlayer resumePlaying: sound quickStart: false]. ! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'jm 6/1/2001 01:30'! mouseMove: evt | noteMorphs chordRect sound | soundsPlaying ifNil: [^ self]. self autoScrollForX: evt cursorPoint x. "Play all notes at the cursor time" noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height). chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1. soundsPlayingMorph delete. soundsPlayingMorph _ Morph newBounds: chordRect color: Color green. self addMorphBack: soundsPlayingMorph. noteMorphs do: [:m | "Add any new sounds" (soundsPlaying includesKey: m) ifFalse: [sound _ m soundOfDuration: 999.0. soundsPlaying at: m put: sound. SoundPlayer resumePlaying: sound quickStart: false]]. soundsPlaying keys do: [:m | "Remove any sounds no longer in selection." (noteMorphs includes: m) ifFalse: [(soundsPlaying at: m) stopGracefully. soundsPlaying removeKey: m]]. ! ! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color white! ! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:01'! initialize "initialize the state of the receiver" super initialize. "" self extent: 400 @ 300. showMeasureLines _ true. showBeatLines _ false. self timeSignature: 4 over: 4. self clipSubmorphs: true! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: aMenu hand: aHandMorph super addCustomMenuItems: aMenu hand: aHandMorph. aMenu add: 'expand time' translated action: #expandTime. aMenu add: 'contract time' translated action: #contractTime. aMenu addLine. aMenu add: 'add movie clip player' translated action: #addMovieClipPlayer. (self valueOfProperty: #dragNDropEnabled) == true ifTrue: [aMenu add: 'close drag and drop' translated action: #disableDragNDrop] ifFalse: [aMenu add: 'open drag and drop' translated action: #enableDragNDrop]. ! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'yo 2/11/2005 10:19'! invokeScoreMenu: evt "Invoke the score's edit menu." | menu subMenu | menu _ MenuMorph new defaultTarget: self. menu addList: {{'cut' translated. #cutSelection}. {'copy' translated. #copySelection}. {'paste' translated. #insertSelection}. {'paste...' translated. #insertTransposed}}. menu addLine. menu addList: {{'legato' translated. #selectionBeLegato}. {'staccato' translated. #selectionBeStaccato}. {'normal' translated. #selectionBeNormal}}. menu addLine. menu addList: {{'expand time' translated. #expandTime}. {'contract time' translated. #contractTime}}. menu addLine. subMenu _ MenuMorph new defaultTarget: self. (2 to: 12) do: [:i | subMenu add: i printString selector: #beatsPerMeasure: argument: i]. menu add: 'time ' translated, beatsPerMeasure printString subMenu: subMenu. subMenu _ MenuMorph new defaultTarget: self. #(2 4 8) do: [:i | subMenu add: i printString selector: #notePerBeat: argument: i]. menu add: 'sig ' translated, notePerBeat printString subMenu: subMenu. menu addLine. showMeasureLines ifTrue: [menu add: 'hide measure lines' translated action: #measureLinesOnOff] ifFalse: [menu add: 'show measure lines' translated action: #measureLinesOnOff]. showBeatLines ifTrue: [menu add: 'hide beat lines' translated action: #beatLinesOnOff] ifFalse: [menu add: 'show beat lines' translated action: #beatLinesOnOff]. menu addLine. menu add: 'add keyboard' translated action: #addKeyboard. menu popUpEvent: evt in: self world. ! ! !PianoRollScoreMorph methodsFor: 'private' stamp: 'md 11/14/2003 16:57'! removedMorph: aMorph | trackSize | trackSize _ score ambientTrack size. score removeAmbientEventWithMorph: aMorph. trackSize = score ambientTrack size ifFalse: ["Update duration if we removed an event" scorePlayer updateDuration]. ^super removedMorph: aMorph! ! !PianoRollScoreMorph commentStamp: '<historical>' prior: 0! A PianoRollScoreMorph displays a score such as a MIDIScore, and will scroll through it tracking the progress of a ScorePlayerMorph (from which it is usually spawned). timeScale is in pixels per score tick. Currently the ambient track (for synchronizing thumbnails, eg) is treated specially here and in the score. This should be cleaned up by adding a trackType or something like it in the score.! !PinMorph methodsFor: 'geometry' stamp: 'aoy 2/15/2003 21:23'! position: p "Adhere to owner bounds, and apply gridding" | r side p1 corners c1 c2 sideIndex | r := owner bounds. side := r sideNearestTo: p. p1 := r pointNearestTo: p. "a point on the border" p1 := (side = #top or: [side = #left]) ifTrue: [r topLeft + (p1 - r topLeft grid: 4 @ 4)] ifFalse: [ r bottomRight + (p1 - r bottomRight grid: 4 @ 4)]. "Update pin spec(5) = side index + fraction along side" corners := r corners. sideIndex := #(#left #bottom #right #top) indexOf: side. c1 := corners at: sideIndex. c2 := corners atWrap: sideIndex + 1. pinSpec pinLoc: sideIndex + ((p1 dist: c1) / (c2 dist: c1) min: 0.99999). "Set new position with appropriate offset." side = #top ifTrue: [super position: p1 - (0 @ 8)]. side = #left ifTrue: [super position: p1 - (8 @ 0)]. side = #bottom ifTrue: [super position: p1]. side = #right ifTrue: [super position: p1]. wires do: [:w | w pinMoved]! ! !PinMorph methodsFor: 'wires' stamp: 'dgd 2/22/2003 14:38'! startWiring: event "Start wiring from this pin" | origin handle candidates candidate wiringColor wire | origin := self wiringEndPoint. candidates := OrderedCollection new. "Later this could be much faster if we define pinMorphsDo: so that it doesn't go too deep and bypasses non-widgets." self pasteUpMorph allMorphsDo: [:m | ((m isMemberOf: PinMorph) and: [m canDockWith: self]) ifTrue: [candidates add: m]]. handle := NewHandleMorph new followHand: event hand forEachPointDo: [:newPoint | candidate := candidates detect: [:m | m containsPoint: newPoint] ifNone: [nil]. wiringColor := candidate isNil ifTrue: [Color black] ifFalse: [Color red]. handle removeAllMorphs; addMorph: (PolygonMorph vertices: (Array with: origin with: newPoint) color: Color black borderWidth: 1 borderColor: wiringColor)] lastPointDo: [:lastPoint | (self wireTo: candidate) ifTrue: [wire := (WireMorph vertices: (Array with: origin with: lastPoint) color: Color black borderWidth: 1 borderColor: Color black) fromPin: self toPin: candidate. self pasteUpMorph addMorph: wire. self addWire: wire. candidate addWire: wire]]. event hand world addMorph: handle. handle startStepping! ! !PinMorph methodsFor: 'wires' stamp: 'dgd 2/22/2003 14:38'! wireTo: otherPin "Note must return true or false indicating success" (otherPin isNil or: [otherPin == self]) ifTrue: [^false]. self hasVariable ifTrue: [otherPin hasVariable ifTrue: [self mergeVariableWith: otherPin] ifFalse: [otherPin shareVariableOf: self]] ifFalse: [otherPin hasVariable ifTrue: [self shareVariableOf: otherPin] ifFalse: [self addModelVariable. otherPin shareVariableOf: self]]. component model changed: pinSpec modelReadSelector. ^true! ! !PinSpec methodsFor: 'variables' stamp: 'dgd 2/22/2003 19:00'! hasVariable ^modelReadSelector notNil or: [modelWriteSelector notNil]! ! !Player methodsFor: 'copying' stamp: 'tk 9/4/2001 11:10'! veryDeepFixupWith: deepCopier | old | "Any uniClass inst var may have been weakly copied. If they were in the tree being copied, fix them up, otherwise point to the originals." super veryDeepFixupWith: deepCopier. Player instSize + 1 to: self class instSize do: [:ii | old _ self instVarAt: ii. self instVarAt: ii put: (deepCopier references at: old ifAbsent: [old])]. ! ! !Player methodsFor: 'copying' stamp: 'tk 9/5/2001 09:43'! veryDeepInner: deepCopier "Special code that handles user-added instance variables of a uniClass. Copy all of my instance variables. Some need to be not copied at all, but shared. This is special code for the dictionary. See DeepCopier." | instVar weak subAss | super veryDeepInner: deepCopier. "my own instance variables are completely normal" costume _ costume veryDeepCopyWith: deepCopier. costumes _ costumes veryDeepCopyWith: deepCopier. Player instSize + 1 to: self class instSize do: [:index | instVar _ self instVarAt: index. weak _ instVar isMorph | instVar isPlayerLike. (subAss _ deepCopier references associationAt: instVar ifAbsent: [nil]) "use association, not value, so nil is an exceptional value" ifNil: [weak ifFalse: [ self instVarAt: index put: (instVar veryDeepCopyWith: deepCopier)]] ifNotNil: [self instVarAt: index put: subAss value]. ]. ! ]style[(25 205 10 659)f1b,f1,f1LDeepCopier Comment;,f1! ! !Player methodsFor: 'costume' stamp: 'sw 9/30/2004 04:29'! ceaseHavingAParameterFor: aSelector "Make the script represented by aSelector cease bearing a parameter" | newSel | self renameScript: aSelector newSelector: (newSel _ (aSelector copyWithout: $:) asSymbol). (self scriptEditorFor: newSel) assureParameterTilesValid; install! ! !Player methodsFor: 'costume' stamp: 'sw 7/18/2002 11:26'! changeParameterTypeFor: aSelector "Change the parameter type for the given selector. Not currently sent, since types are now set by direct manipulation in the Scriptor header. If this were reinstated someday, there would probably be an issue about getting correct-looking Parameter tile(s) into the Scriptor header(s)" | current typeChoices typeChosen | current _ self typeforParameterFor: aSelector. typeChoices _ Vocabulary typeChoices. typeChosen _ (SelectionMenu selections: typeChoices lines: #()) startUpWithCaption: ('Choose the TYPE for the parameter (currently ', current, ')'). self setParameterFor: aSelector toType: typeChosen ! ! !Player methodsFor: 'costume' stamp: 'sw 2/27/2001 18:28'! clearOwnersPenTrails "Clear the pen trails of the containing playfield" self costume referencePlayfield clearTurtleTrails! ! !Player methodsFor: 'costume' stamp: 'sw 3/4/2001 13:57'! clearPenTrails "Allow old code invoking the short-lived deviant clearPenTrails command to continue to work when imported from a bj image into a mainstream image. For backward compatibility only!!" self costume referencePlayfield clearTurtleTrails! ! !Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:05'! costumesDo: aBlock "Evaluate aBlock against every real (not flex) costume known to the receiver, starting with the current costume." costume ifNotNil: [ aBlock value: costume renderedMorph ]. costumes ifNil: [^ self]. costumes do: [:aCostume | aCostume ~~ costume ifTrue: [aBlock value: aCostume renderedMorph]]! ! !Player methodsFor: 'costume' stamp: 'mga 11/18/2003 11:23'! flipHorizontal self costume flipHorizontal! ! !Player methodsFor: 'costume' stamp: 'mga 11/18/2003 11:23'! flipVertical self costume flipVertical! ! !Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:05'! hasCostumeThatIsAWorld self costumesDo: [ :aCostume | (aCostume isWorldMorph) ifTrue: [^ true]]. ^ false! ! !Player methodsFor: 'costume' stamp: 'nk 9/4/2004 17:04'! hasOnlySketchCostumes "Answer true if the only costumes assocaited with this Player are SketchMorph costumes" self costumesDo: [ :aCostume | aCostume isSketchMorph ifFalse: [^ false]]. ^ true! ! !Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:01'! knownSketchCostumeWithSameFormAs: aSketchMorph | itsForm | itsForm := aSketchMorph form. ^ costumes ifNotNil: [costumes detect: [:c | c isSketchMorph and: [c form == itsForm]] ifNone: []]! ! !Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:01'! recaptureUniqueCostumes "Recapture all unique sketch-like costumes. Debugging only." | unique | costumes ifNil:[^self]. unique := PluggableSet new equalBlock:[:s1 :s2| s1 form == s2 form]; hashBlock:[:s| s form identityHash]. unique addAll: (costumes select:[:c| c isSketchMorph]). unique := unique asIdentitySet. costumes := costumes select:[:c| (c isSketchMorph) not or:[unique includes: c]]. ! ! !Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:02'! rememberCostume: aCostume "Put aCostume in my remembered-costumes list, as the final element" | costumeToRemember existing | costumeToRemember _ aCostume renderedMorph. "Remember real morphs, not their transformations" costumes ifNil: [costumes _ OrderedCollection new]. existing _ (costumeToRemember isSketchMorph) ifTrue: [self knownSketchCostumeWithSameFormAs: costumeToRemember] ifFalse: [costumes detect: [:c | c == costumeToRemember] ifNone: [nil]]. costumes _ costumes copyWithout: existing. costumes addLast: costumeToRemember! ! !Player methodsFor: 'costume' stamp: 'mir 6/13/2001 15:28'! renderedCostume: aMorph "Make aMorph be the receiver's rendered costume; if flexing is currently in effect, make the new morph be flexed correspondingly" self renderedCostume: aMorph remember: true! ! !Player methodsFor: 'costume' stamp: 'sw 12/12/2001 14:13'! renderedCostume: aMorph remember: rememberCostume "Make aMorph be the receiver's rendered costume; if flexing is currently in effect, make the new morph be flexed correspondingly" | renderedMorph known anEventHandler w baseGraphic | renderedMorph _ costume renderedMorph. renderedMorph == aMorph ifTrue: [^ self]. baseGraphic _ costume renderedMorph valueOfProperty: #baseGraphic. rememberCostume ifTrue: [self rememberCostume: renderedMorph]. renderedMorph changed. w _ renderedMorph world. "Copy 'player state' (e.g., state which should be associated with the player but is stored in the morph itself these days) from the old rendered morph the new morph." aMorph rotationStyle: renderedMorph rotationStyle. aMorph forwardDirection: renderedMorph forwardDirection. "Note: referencePosition is *not* state but #moveTo: behavior" aMorph referencePosition: renderedMorph referencePosition. anEventHandler _ renderedMorph eventHandler. costume isFlexMorph ifTrue: [costume adjustAfter: [costume replaceSubmorph: renderedMorph by: aMorph]] ifFalse: [costume owner ifNotNil: [costume owner replaceSubmorph: costume by: aMorph]. aMorph player: self. aMorph actorState: costume actorState. (known _ costume knownName) ifNotNil: [aMorph setNameTo: known]. costume _ aMorph. w ifNotNil: [w stopStepping: renderedMorph. w startStepping: aMorph]]. baseGraphic ifNotNil: [self setBaseGraphic: baseGraphic]. aMorph eventHandler: anEventHandler. aMorph changed! ! !Player methodsFor: 'costume' stamp: 'nk 6/12/2004 10:02'! restoreBaseGraphic "Restore my base graphic" | cos | ((cos _ self costume renderedMorph) isSketchMorph) ifTrue: [cos restoreBaseGraphic]! ! !Player methodsFor: 'costume' stamp: 'sw 7/22/2002 17:44'! setParameterFor: aSelector toType: aTypeSymbol "Set the parameter type for the given selector" | aUniclassScript | aTypeSymbol isEmptyOrNil ifTrue: [^ self]. (self typeforParameterFor: aSelector) = aTypeSymbol ifTrue: [^ self]. aUniclassScript _ self class scripts at: aSelector. aUniclassScript argumentVariables first variableType: aTypeSymbol. aUniclassScript currentScriptEditorDo: [:aScriptEditor | aScriptEditor assureParameterTilesValid]. self updateAllViewersAndForceToShow: #scripts ! ! !Player methodsFor: 'costume' stamp: 'tak 1/17/2005 13:32'! stamp "stamp an image of ourself onto the pen trails form" costume stamp! ! !Player methodsFor: 'costume' stamp: 'RAA 5/18/2001 09:21'! stampAndErase self stamp. self erase.! ! !Player methodsFor: 'costume' stamp: 'sw 9/30/2004 04:49'! startHavingParameterFor: aSelector "Start having a parameter for the given selector. After this change, the script name will change by the addition of a colon." | newSelector | self renameScript: aSelector newSelector: (newSelector _ (aSelector, ':') asSymbol). (self scriptEditorFor: newSelector) install! ! !Player methodsFor: 'costume' stamp: 'sw 3/11/2003 00:32'! tearOffButtonToFireScriptForSelector: aSelector "Tear off a button to fire the script for the given selector" | aButton props | Preferences useButtonProprtiesToFire ifFalse: [aButton _ ScriptActivationButton new. aButton initializeForPlayer: self uniclassScript: (self class scripts at: aSelector). ^ aButton openInHand]. (aButton _ RectangleMorph new) useRoundedCorners; color: Color yellow. props _ aButton ensuredButtonProperties. props target: self; actionSelector: #runScript:; arguments: {aSelector}; delayBetweenFirings: 80; actWhen: #mouseUp; mouseDownHaloWidth: 8; wantsRolloverIndicator: true; mouseOverHaloWidth: 5; establishEtoyLabelWording. aButton width: aButton submorphs first width + 20; height: 20. self currentHand attachMorph: aButton. ! ! !Player methodsFor: 'costume' stamp: 'sw 7/5/2002 22:16'! typeforParameterFor: aSelector "Answer the type of the parameter for the given selector" (self class scripts at: aSelector ifAbsent: [nil]) ifNotNilDo: [:aScript | ^ aScript argumentVariables first variableType]. self error: 'No parameter type for ', aSelector. ^ #Number! ! !Player methodsFor: 'costume' stamp: 'mir 6/13/2001 15:29'! wearCostumeOf: anotherPlayer "Put on a costume similar to the one currently worn by anotherPlayer" self renderedCostume: (anotherPlayer costume renderedMorph asWearableCostumeOfExtent: self costume extent) remember: anotherPlayer costume shouldRememberCostumes! ! !Player methodsFor: 'macpal' stamp: 'sw 3/20/2001 13:28'! isUniversalTiles "Return true if I (my world) uses universal tiles. This message can be called in places where the current World is not known, such as when writing out a project. For information about the writingUniversalTiles thing, contact Ted Kaehler." ^ costume world ifNil: [ScriptEditorMorph writingUniversalTiles == true "only valid during a project write"] ifNotNil: [Preferences universalTiles]! ! !Player methodsFor: 'menus' stamp: 'ar 2/12/2001 18:50'! step "obsolete" ^self stepAt: Time millisecondClockValue.! ! !Player methodsFor: 'misc' stamp: 'nk 8/18/2004 16:43'! adoptScriptsFrom "Let the user click on another object form which the receiver should obtain scripts and code" | aMorph | Sensor waitNoButton. aMorph _ ActiveWorld chooseClickTarget. aMorph ifNil: [^ Beeper beep]. (((aMorph isSketchMorph) and: [aMorph player belongsToUniClass]) and: [self belongsToUniClass not]) ifTrue: [costume acquirePlayerSimilarTo: aMorph player] ifFalse: [Beeper beep]! ! !Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:53'! allOpenViewers "Answer a list of all the viewers open on the receiver. Include viewers in closed flaps" | aWorld all | (aWorld := self costume world) ifNil: [^#()]. all := aWorld allMorphs. aWorld closedViewerFlapTabs do: [:aTab | all addAll: aTab referent allMorphs]. ^all select: [:m | (m isStandardViewer) and: [m scriptedPlayer == self]]! ! !Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:54'! allOpenViewersOnReceiverAndSiblings "Answer a list of all the viewers open on the receiver and any of its sibling instances. Include viewers in closed flaps" | aWorld all | (aWorld := self costume world) ifNil: [^#()]. all := aWorld allMorphs. aWorld closedViewerFlapTabs do: [:aTab | all addAll: aTab referent allMorphs]. ^all select: [:m | (m isStandardViewer) and: [m scriptedPlayer class == self class]]! ! !Player methodsFor: 'misc' stamp: 'sw 7/4/2004 00:20'! arrowDeltaFor: aGetSelector "Answer the arrowDelta to use in conjunction with a readout for aGetSelector, which will be of the form 'getXXX'" costume ifNotNil: [^ costume renderedMorph arrowDeltaFor: aGetSelector]. ^ 1 "For the future, possibly: If we want the SlotInformation for a user-defined slot to be able to specify a standard arrowDelta for that slot, we'd include something like the following... | aSlotName slotInfo | aSlotName _ Utilities inherentSelectorForGetter: aGetSelector. (slotInfo _ self slotInfoAt: aSlotName ifAbsent: [nil]) ifNotNil: [^ slotInfo arrowDelta]." ! ! !Player methodsFor: 'misc' stamp: 'sw 3/17/2005 00:47'! beNotZero: aNumber "This is a runtime check if the arg to divide in a script is zero. If it is, put up a warning message. Return 0.001 instead of 0. Note the time. If fails again within 1 min., don't tell the user again." aNumber = 0 ifFalse: [^ aNumber]. "normal case" "We have a problem" TimeOfError ifNil: [TimeOfError _ Time totalSeconds] ifNotNil: [(Time totalSeconds - TimeOfError) > 45 ifTrue: [ TimeOfError _ Time totalSeconds. "in case user interrupt and reenter" self inform: 'Dividing by zero makes a number too large for even a Sorcerer to handle. Please change your script.' translated. TimeOfError _ Time totalSeconds]]. ^ 0.001! ! !Player methodsFor: 'misc' stamp: 'sw 7/28/2004 20:51'! beRevealedInActiveWorld "Reveal my corresponding morph in the active world" self revealPlayerIn: ActiveWorld! ! !Player methodsFor: 'misc' stamp: 'gk 2/23/2004 20:51'! beep: soundName "Play given sound or at least beep." SoundService default playSoundNamedOrBeep: soundName ! ! !Player methodsFor: 'misc' stamp: 'sw 3/20/2001 12:21'! browseEToyVocabulary "Open a protocol browser on the receiver, showing its etoy vocabulary" | littleMe | littleMe _ self assureUniClass. (InstanceBrowser new useVocabulary: Vocabulary eToyVocabulary) openOnObject: littleMe inWorld: ActiveWorld showingSelector: nil! ! !Player methodsFor: 'misc' stamp: 'sw 12/13/2001 14:34'! color: myColor sees: externalColor "Answer whether any pixel of one color on my costume is coincident with any pixel of a second color in its surround. Returns false if the costume is not currently in the world" self costume isInWorld ifFalse: [^ false]. ^ self costume color: myColor sees: externalColor! ! !Player methodsFor: 'misc' stamp: 'sw 9/13/2002 17:52'! decimalPlacesForGetter: aGetter "Answer the number of decimal places wanted when displaying the getter's value. Answer nil if this object does not have a personal preference regarding this getter." ^ costume decimalPlacesForGetter: aGetter! ! !Player methodsFor: 'misc' stamp: 'sw 7/4/2004 00:29'! defaultFloatPrecisionFor: aGetSelector "Answer the float position to use in conjunction with a readout for aGetSelector, which will be of the form 'getXXX'" | aSlotName slotInfo | aSlotName _ Utilities inherentSelectorForGetter: aGetSelector. (slotInfo _ self slotInfoAt: aSlotName ifAbsent: [nil]) ifNotNil: [^ slotInfo floatPrecision]. self costume ifNotNil: [^ self costume renderedMorph defaultFloatPrecisionFor: aGetSelector]. ^ 1! ! !Player methodsFor: 'misc' stamp: 'sw 7/28/2004 20:52'! entryForPlayersTool: aPlayersTool "Answer an entry for the receiver in the All Players tool" ^ PlayerSurrogate newRow playerRepresented: self! ! !Player methodsFor: 'misc' stamp: 'sw 7/8/2004 01:29'! erase "Dismiss the receiver from the screen. It can subsequently be found in the trash if need be, provided the preserveTrash preference is set to true" self costume topRendererOrSelf dismissViaHalo! ! !Player methodsFor: 'misc' stamp: 'ka 3/25/2004 05:25'! grabPlayerIn: aWorld "Invoked from a Viewer: rip my morph out of its container, wherever that may be, and place it in the hand, being careful to set things up so that if the subsequent drop is rejected, the morph will end up in a visible location on the screen" | aMorph newPosition | self costume == aWorld ifTrue: [^ self]. ActiveHand releaseMouseFocus. (aMorph _ self costume) visible: true. newPosition _ ActiveHand position - (aMorph extent // 2). aMorph isInWorld ifTrue: [aMorph goHome. aMorph formerPosition: aMorph positionInWorld] ifFalse: [aMorph formerPosition: aWorld center]. aMorph formerOwner: ActiveWorld. aMorph position: newPosition. ActiveHand targetOffset: aMorph position - ActiveHand position. ActiveHand addMorphBack: aMorph.! ! !Player methodsFor: 'misc' stamp: 'sw 7/19/2004 16:41'! grabPlayerInActiveWorld "Invoked from a Viewer: rip my morph out of its container, wherever that may be, and place it in the hand, being careful to set things up so that if the subsequent drop is rejected, the morph will end up in a visible location on the screen" self grabPlayerIn: ActiveWorld! ! !Player methodsFor: 'misc' stamp: 'nk 6/12/2004 10:01'! impartSketchScripts "Let the user designate another object to which my scripts and code should be imparted" | aMorph | Sensor waitNoButton. aMorph _ ActiveWorld chooseClickTarget. aMorph ifNil: [^ self]. (aMorph renderedMorph isSketchMorph) ifTrue: [aMorph acquirePlayerSimilarTo: self]! ! !Player methodsFor: 'misc' stamp: 'sw 7/28/2001 01:03'! indicateLocationOnScreen "Give momentary feedback on screen until mouse button is clicked" | bds | bds _ self costume boundsInWorld. 5 timesRepeat: [Display reverse: bds. (Delay forMilliseconds: 80) wait. Display reverse: bds. (Delay forMilliseconds: 200) wait.]. costume changed! ! !Player methodsFor: 'misc' stamp: 'sw 1/10/2005 00:08'! makeBounceSound: soundName "Having bounced off an edge, produce the given sound" Preferences soundsEnabled ifTrue: [self costume playSoundNamed: soundName]! ! !Player methodsFor: 'misc' stamp: 'sw 9/13/2002 17:53'! noteDecimalPlaces: aNumber forGetter: aGetter "Note the given preference of decimal places for the given getter" costume noteDecimalPlaces: aNumber forGetter: aGetter! ! !Player methodsFor: 'misc' stamp: 'sw 10/6/2004 11:17'! offerAlternateViewerMenuFor: aViewer event: evt "Put up an alternate Viewer menu on behalf of the receiver." | aMenu aWorld | aWorld _ aViewer world. aMenu _ MenuMorph new defaultTarget: self. costumes ifNotNil: [(costumes size > 1 or: [costumes size == 1 and: [costumes first ~~ costume renderedMorph]]) ifTrue: [aMenu add: 'forget other costumes' translated target: self selector: #forgetOtherCostumes]]. aMenu add: 'expunge empty scripts' translated target: self action: #expungeEmptyScripts. aMenu addLine. aMenu add: 'choose vocabulary...' translated target: aViewer action: #chooseVocabulary. aMenu balloonTextForLastItem: 'Choose a different vocabulary for this Viewer.' translated. aMenu add: 'choose limit class...' translated target: aViewer action: #chooseLimitClass. aMenu balloonTextForLastItem: 'Specify what the limitClass should be for this Viewer -- i.e., the most generic class whose methods and categories should be considered here.' translated. aMenu add: 'open standard lexicon' translated target: aViewer action: #openLexicon. aMenu balloonTextForLastItem: 'open a window that shows the code for this object in traditional programmer format' translated. aMenu add: 'open lexicon with search pane' translated target: aViewer action: #openSearchingProtocolBrowser. aMenu balloonTextForLastItem: 'open a lexicon that has a type-in pane for search (not recommended!!)' translated. aMenu addLine. aMenu add: 'inspect morph' translated target: costume selector: #inspect. aMenu add: 'inspect player' translated target: self selector: #inspect. self belongsToUniClass ifTrue: [aMenu add: 'browse class' translated target: self action: #browsePlayerClass. aMenu add: 'inspect class' translated target: self class action: #inspect]. aMenu add: 'inspect this Viewer' translated target: aViewer selector: #inspect. aMenu add: 'inspect this Vocabulary' translated target: aViewer currentVocabulary selector: #inspect. aMenu addLine. aMenu add: 'relaunch this Viewer' translated target: aViewer action: #relaunchViewer. aMenu add: 'attempt repairs' translated target: ActiveWorld action: #attemptCleanup. aMenu add: 'view morph directly' translated target: aViewer action: #viewMorphDirectly. aMenu balloonTextForLastItem: 'opens a Viewer directly on the rendered morph.' translated. (costume renderedMorph isSketchMorph) ifTrue: [aMenu addLine. aMenu add: 'impart scripts to...' translated target: self action: #impartSketchScripts]. aMenu popUpEvent: evt in: aWorld! ! !Player methodsFor: 'misc' stamp: 'sw 3/3/2004 00:21'! offerViewerMenuFor: aViewer event: evt "Put up the Viewer menu on behalf of the receiver. If the shift key is held down, put up the alternate menu. The menu omits the 'add a new variable' item when in eToyFriendly mode, as per request from teachers using Squeakland in 2003 once the button for adding a new variable was added to the viewer" | aMenu aWorld | (evt notNil and: [evt shiftPressed]) ifTrue: [^ self offerAlternateViewerMenuFor: aViewer event: evt]. aWorld _ aViewer world. aMenu _ MenuMorph new defaultTarget: self. Preferences eToyFriendly ifFalse: "exclude this from squeakland-like UI " [aMenu add: 'add a new variable' translated target: self action: #addInstanceVariable. aMenu balloonTextForLastItem: 'Add a new variable to this object and all of its siblings. You will be asked to supply a name for it.' translated]. aMenu add: 'add a new script' translated target: aViewer action: #newPermanentScript. aMenu balloonTextForLastItem: 'Add a new script that will work for this object and all of its siblings' translated. aMenu addLine. aMenu add: 'grab me' translated target: self selector: #grabPlayerIn: argument: aWorld. aMenu balloonTextForLastItem: 'This will actually pick up the object this Viewer is looking at, and hand it to you. Click the (left) button to drop it' translated. aMenu add: 'reveal me' translated target: self selector: #revealPlayerIn: argument: aWorld. aMenu balloonTextForLastItem: 'If you have misplaced the object that this Viewer is looking at, use this item to (try to) make it visible' translated. aMenu addLine. aMenu add: 'tile representing me' translated action: #tearOffTileForSelf. aMenu add: 'add search pane' translated target: aViewer action: #addSearchPane. aMenu addLine. aMenu add: 'more...' translated target: self selector: #offerAlternateViewerMenuFor:event: argumentList: {aViewer. evt}. aMenu popUpEvent: evt in: aWorld ! ! !Player methodsFor: 'misc' stamp: 'sw 3/7/2001 12:56'! openSearchingVocabularyBrowser "Open a vocabulary browser on the receiver, showing its etoy vocabulary. No senders; a disused but presumably still viable path, provisionally retained" (Lexicon new useVocabulary: Vocabulary fullVocabulary) openWithSearchPaneOn: self class inWorld: self currentWorld! ! !Player methodsFor: 'misc' stamp: 'tak 1/21/2005 11:59'! overlaps: aPlayer "Answer whether my costume overlaps that of another player" | goalCostume intersection myShadow goalShadow bb myRect goalRect | aPlayer ifNil: [^false]. goalCostume := aPlayer costume. costume world == goalCostume world ifFalse: [^false]. "check if the 2 player costumes intersect" intersection := costume bounds intersect: goalCostume bounds. (intersection width = 0 or: [intersection height = 0]) ifTrue: [^false] ifFalse: ["check if the overlapping region is non-transparent" "compute 1-bit, black and white versions (stencils) of the intersecting part of each morph's costume" myRect := intersection translateBy: 0 @ 0 - costume topLeft. myShadow := (costume imageForm contentsOfArea: myRect) stencil. goalRect := intersection translateBy: 0 @ 0 - goalCostume topLeft. goalShadow := (goalCostume imageForm contentsOfArea: goalRect) stencil. "compute a pixel-by-pixel AND of the two stencils. Result will be black (pixel value = 1) where black parts of the stencils overlap" bb := BitBlt toForm: myShadow. bb copyForm: goalShadow to: 0 @ 0 rule: Form and. "return TRUE if resulting form contains any black pixels" ^(bb destForm tallyPixelValues second) > 0]! ! !Player methodsFor: 'misc' stamp: 'sw 7/28/2001 01:05'! revealPlayerIn: aWorld "Reveal the receiver if at all possible in the world; once it's visible, flash its image for a bit, and leave it with its halo showing" | aMorph | (aMorph _ self costume) isInWorld ifTrue: [aMorph goHome. self indicateLocationOnScreen. aMorph addHalo. ^ self]. "It's hidden somewhere; search for it" aWorld submorphs do: [:m | (m succeededInRevealing: self) ifTrue: "will have obtained halo already" [aWorld doOneCycle. self indicateLocationOnScreen. ^ self]]. "The morph is truly unreachable in this world at present. So extract it from hyperspace, and place it at center of screen, wearing a halo." aMorph isWorldMorph ifFalse: [aWorld addMorphFront: aMorph. aMorph position: aWorld bounds center. aMorph addHalo] ! ! !Player methodsFor: 'misc' stamp: 'dgd 2/22/2003 13:45'! revertToUnscriptedPlayerIfAppropriate | anInstance | (self class selectors notEmpty or: [self class instVarNames notEmpty]) ifTrue: [^self]. anInstance := UnscriptedPlayer new. anInstance initializeCostumesFrom: self. self become: anInstance! ! !Player methodsFor: 'misc' stamp: 'gm 2/22/2003 14:54'! tearOffTileForSelf | tiles | self currentHand attachMorph: (tiles := self tileReferringToSelf). (tiles isSyntaxMorph) ifTrue: [Preferences tileTranslucentDrag ifTrue: [tiles lookTranslucent] ifFalse: [tiles align: tiles topLeft with: self currentHand position + tiles cursorBaseOffset]]! ! !Player methodsFor: 'misc' stamp: 'sw 5/4/2001 07:12'! tileReferringToSelf "answer a tile that refers to the receiver" | aTile nn tile | Preferences universalTiles ifTrue: [nn _ self externalName. "name it, if necessary, and put in References" (References includesKey: nn asSymbol) ifFalse: [ References at: nn asSymbol put: self]. tile _ SyntaxMorph new parseNode: (VariableNode new name: nn key: nn code: nil). tile layoutInset: 1; addMorph: (tile addString: nn special: false). tile color: (SyntaxMorph translateColor: #variable). tile extent: tile firstSubmorph extent + (2@2). ^ tile]. aTile _ TileMorph new setToReferTo: self. ^ aTile! ! !Player methodsFor: 'misc' stamp: 'sw 9/6/2002 13:11'! touchesA: aPrototypicalPlayer "Answer whether the receiver overlaps any player who wears a Sketch costume and who is of the same class as the prototypicalPlayer and who is wearing the same bitmap, but who is *not that player itself*!! This is an extreme case of a function highly customized (by Bob Arning) to suit a single, idiosycratic, and narrow demo need of Alan's. Consult: http://groups.yahoo.com/group/squeak/message/40560" | envelope trueNeighbor trueGoal trueSelf itsPlayer | aPrototypicalPlayer ifNil: [^ false]. envelope _ costume owner ifNil: [^ false]. trueSelf _ costume renderedMorph. trueGoal _ aPrototypicalPlayer costume renderedMorph. envelope submorphs do: [:each | trueNeighbor _ each renderedMorph. (trueNeighbor == trueGoal or: [trueNeighbor == trueSelf]) ifFalse: [(itsPlayer _ each player) ifNotNil: [(itsPlayer overlaps: self) ifTrue: [(trueGoal appearsToBeSameCostumeAs: trueNeighbor) ifTrue: [^ true]]]]]. ^ false ! ! !Player methodsFor: 'misc' stamp: 'dgd 9/1/2003 14:17'! unusedScriptName "answer a name of the form 'scriptN', where N is one higher than the highest-numbered similarly-named script" | highestThus aPair | highestThus _ 0. self class tileScriptNames do: [:aName | aPair _ (aName copyWithout: $:) stemAndNumericSuffix. aPair first = 'script' translated ifTrue: [highestThus _ highestThus max: aPair last]]. ^ ('script' translated, (highestThus + 1) printString) asSymbol! ! !Player methodsFor: 'pen' stamp: 'nk 6/12/2004 10:00'! addPlayerMenuItemsTo: aMenu hand: aHandMorph "Note that these items are primarily available in another way in an object's Viewer" | subMenu | subMenu _ MenuMorph new defaultTarget: self. self getPenDown ifTrue: [subMenu add: 'lift pen' action: #liftPen] ifFalse: [subMenu add: 'lower pen' action: #lowerPen]. subMenu add: 'choose pen size...' action: #choosePenSize. subMenu add: 'choose pen color...' action: #choosePenColor:. aMenu add: 'pen...' subMenu: subMenu. (costume renderedMorph isSketchMorph) ifTrue: [self belongsToUniClass ifFalse: [aMenu add: 'adopt scripts from...' target: self action: #adoptScriptsFrom] ifTrue: [aMenu add: 'impart scripts to...' target: self action: #impartSketchScripts]]! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:16'! arrowheadsOnAllPens "Only for the Player of a World" self costume arrowheadsOnAllPens! ! !Player methodsFor: 'pen' stamp: 'sw 10/4/2002 13:14'! clearTurtleTrails "Clear all turtle trails within my costume, presumed to be a playfield" self costume renderedMorph clearTurtleTrails! ! !Player methodsFor: 'pen' stamp: 'sw 4/17/2003 12:26'! getDotSize "Answer the receiver's dotSize" ^ self costume renderedMorph valueOfProperty: #trailDotSize ifAbsentPut: [6]! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:47'! getPenArrowheads "Answer a boolean indicating whether the receiver's pen will draw an arrowhead at the end of a stroke" ^ self actorState getPenArrowheads! ! !Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:28'! getTrailStyle "Answer the receiver's trailStyle" ^ self actorState trailStyle! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 18:14'! noArrowheadsOnAllPens "Only for the Player of a Playfield" self costume noArrowheadsOnAllPens! ! !Player methodsFor: 'pen' stamp: 'sw 4/17/2003 11:56'! setDotSize: aNumber "Set the trail dot size as indicated, but confine matters to a reasonable range" self costume renderedMorph setProperty: #trailDotSize toValue: ((aNumber max: 1) min: 100)! ! !Player methodsFor: 'pen' stamp: 'tk 10/4/2001 16:48'! setPenArrowheads: penDown "Set whether the pen will draw arrowheads on the ends of strokes" self actorState setPenArrowheads: penDown. ! ! !Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:23'! setTrailStyle: aTrailStyle "Set the trail style" self actorState trailStyle: aTrailStyle ! ! !Player methodsFor: 'pen' stamp: 'sw 3/11/2003 11:22'! trailStyleForAllPens: aTrailStyle "Only for the Player of a World" self costume renderedMorph trailStyleForAllPens: aTrailStyle! ! !Player methodsFor: 'scripting' stamp: 'tk 8/13/2001 09:27'! methodInterfacesForScriptsCategoryIn: aVocabulary "Answer a list of method interfaces for the category #scripts, as seen in a viewer or other tool. The vocabulary argument is not presently used." | myScripts | myScripts _ self class scripts values collect: [:us | (us isKindOf: UserScript) ifTrue: [us as: MethodWithInterface] ifFalse: [us]]. ^ {self methodInterfaceForEmptyScript}, myScripts! ! !Player methodsFor: 'scripts-execution' stamp: 'sw 6/13/2002 10:57'! assureNoScriptOtherThan: aScriptInstantiation hasStatus: aStatus self instantiatedUserScriptsDo: [:aScriptInst | aScriptInst == aScriptInstantiation ifFalse: [aScriptInst resetToNormalIfCurrently: aStatus]]! ! !Player methodsFor: 'scripts-execution' stamp: 'sw 2/6/2001 23:21'! fireOnce "If the receiver has any script armed to be triggered on mouse down and/or mouse-up, run those scripts now -- first the mouseDown ones, then the mouseUp ones." self instantiatedUserScriptsDo: [:aScriptInst | aScriptInst status == #mouseDown ifTrue: [aScriptInst fireOnce]]. self instantiatedUserScriptsDo: [:aScriptInst | aScriptInst status == #mouseUp ifTrue: [aScriptInst fireOnce]]. ! ! !Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:57'! prepareToBeRunning self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation prepareToBeRunning].! ! !Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:04'! runAllTickingScripts: nowTick self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation runIfTicking: nowTick]! ! !Player methodsFor: 'scripts-execution' stamp: 'ar 2/12/2001 18:04'! stepAt: nowTick self runAllTickingScripts: nowTick! ! !Player methodsFor: 'scripts-kernel' stamp: 'NS 1/28/2004 14:41'! acceptScript: aScriptEditorMorph for: aSelector "Accept the tile code in the script editor as the code for the given selector. This branch is only for the classic-tile system, 1997-2001" | aUniclassScript | self class compileSilently: aScriptEditorMorph methodString classified: 'scripts'. aUniclassScript _ self class assuredMethodInterfaceFor: aSelector asSymbol. aUniclassScript currentScriptEditor: aScriptEditorMorph! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 1/4/2005 02:18'! acceptableScriptNameFrom: originalString forScriptCurrentlyNamed: currentName "Produce an acceptable script name, derived from the current name, for the receiver. This method will always return a valid script name that will be suitable for use in the given situation, though you might not like its beauty sometimes." | aString stemAndSuffix proscribed stem suffix withoutColon currentNumArgs withColon | withoutColon _ originalString copyWithoutAll: {$:. $ }. (currentName notNil and: [(currentName copyWithout: $:) = withoutColon]) ifTrue: [^ currentName]. "viz. no change; otherwise, the #respondsTo: check gets in the way" currentNumArgs _ currentName ifNil: [0] ifNotNil: [currentName numArgs]. aString _ withoutColon asIdentifier: false. "get an identifier starting with a lowercase letter" stemAndSuffix _ aString stemAndNumericSuffix. proscribed _ #(self super thisContext costume costumes dependents #true #false size). stem _ stemAndSuffix first. suffix _ stemAndSuffix last. withoutColon _ aString asSymbol. withColon _ (withoutColon, ':') asSymbol. [(proscribed includes: withoutColon) or: [self respondsTo: withoutColon] or: [self respondsTo: withColon] or: [Smalltalk includesKey: withoutColon] or: [Smalltalk includesKey: withColon]] whileTrue: [suffix _ suffix + 1. withoutColon _ (stem, suffix printString) asSymbol. withColon _ (withoutColon, ':') asSymbol]. ^ currentNumArgs = 0 ifTrue: [withoutColon] ifFalse: [withColon]! ! !Player methodsFor: 'scripts-kernel' stamp: 'yo 2/12/2005 19:53'! addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym "The menu provided has the receiver as its argument, and is used as the menu for the given slot-symbol in a line of a Viewer. Add special-case items" (#(copy getNewClone newClone) includes: slotSym) ifTrue: [aMenu add: 'give me a copy now' translated action: #handTheUserACopy]. " (slotSym == #dropShadow) ifTrue: [aMenu add: 'set shadow offset' translated action: #setShadowOffset]. (slotSym == #useGradientFill) ifTrue: [aMenu add: 'set gradient origin...' translated action: #setGradientOffset. aMenu add: 'set gradient direction...' translated action: #setGradientDirection]." ! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:04'! editDescriptionForSelector: aSelector "Allow the user to edit the balloon-help description for the given selector" (self class userScriptForPlayer: self selector: aSelector) editDescription. self updateAllViewers! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/20/2001 02:28'! isEmptyTileScript: aScriptName "Answer whether the script of the given name is an empty classic tile script. Presently disused -- formerly it was all too easy to propagate many empty tile scripts but this difficulty has receded considerably with recent changes, so this has no senders other than from an unusual menu item, and will perhaps die soon" | aUserScript | Preferences universalTiles ifTrue: [^ false]. aUserScript _ self class userScriptForPlayer: self selector: aScriptName. ^ (aUserScript instantiatedScriptEditorForPlayer: self) isEmpty ! ! !Player methodsFor: 'scripts-kernel' stamp: 'dgd 9/1/2003 14:17'! isExpendableScript: aScriptName ^ (self isEmptyTileScript: aScriptName) and: [aScriptName beginsWith: 'script' translated] ! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:03'! makeIsolatedCodePaneForSelector: aSelector "make an isolated code pane for the given selector" MethodHolder makeIsolatedCodePaneForClass: self class selector: aSelector ! ! !Player methodsFor: 'scripts-kernel' stamp: 'mir 7/12/2004 19:41'! methodInterfaceForEmptyScript "Answer a MethodInterface representing Andreas's 'emptyScript' feature" | anInterface | anInterface _ MethodInterface new. anInterface receiverType: #Player. anInterface flagAttribute: #scripts. anInterface wording: (ScriptingSystem wordingForOperator: #emptyScript); helpMessage: 'an empty script; drop on desktop to get a new empty script for this object'. anInterface selector: #emptyScript type: nil setter: nil. ^ anInterface! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 7/17/2002 16:41'! newTextualScriptorFor: aSelector "Sprout a scriptor for aSelector, opening up in textual mode. Rather special-purpose, consult my lone sender" | aMethodWithInterface aScriptEditor | (self class selectors includes: aSelector) ifTrue: [self error: 'selector already exists']. aMethodWithInterface _ self class permanentUserScriptFor: aSelector player: self. aScriptEditor _ aMethodWithInterface instantiatedScriptEditorForPlayer: self. aScriptEditor install. aScriptEditor showSourceInScriptor. aMethodWithInterface selector numArgs == 0 ifTrue: [self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aMethodWithInterface selector]]. "The above assures the presence of a ScriptInstantiation for the new selector in all siblings" self updateAllViewersAndForceToShow: #scripts. ^ aScriptEditor! ! !Player methodsFor: 'scripts-kernel' stamp: 'yo 1/2/2004 06:40'! noteRenameOf: oldSlotName to: newSlotName inPlayer: aPlayer "Note that aPlayer has renamed a slot formerly known as oldSlotName to be newSlotName" self allScriptEditors do: [:anEditor | (anEditor showingMethodPane not and: [anEditor hasScriptReferencing: oldSlotName ofPlayer: aPlayer]) ifTrue: [anEditor replaceReferencesToSlot: oldSlotName inPlayer: aPlayer with: newSlotName]]! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/5/2001 14:01'! removeScriptWithSelector: aSelector "Remove the given script, and get the display right" self removeScript: aSelector fromWorld: self currentWorld ! ! !Player methodsFor: 'scripts-kernel' stamp: 'yo 2/11/2005 15:37'! renameScript: oldSelector "The user has asked to rename the script formerly known by oldSelector; obtain a new selector from the user, check it out, and if all is well, ascribe the new name as appropriate" | reply newSelector aUserScript | self flag: #deferred. "Relax the restriction below, before too long" aUserScript := self class userScriptForPlayer: self selector: oldSelector. aUserScript okayToRename ifFalse: [self inform: 'Sorry, we do not permit you to rename classic-tiled scripts that are currently textually coded. Go back to tile scripts and try again. Humble apologies.' translated. ^self]. reply := FillInTheBlank request: 'Script Name' translated initialAnswer: oldSelector. reply isEmpty ifTrue: [^self]. reply = oldSelector ifTrue: [^Beeper beep]. newSelector := self acceptableScriptNameFrom: reply forScriptCurrentlyNamed: oldSelector. Preferences universalTiles ifTrue: ["allow colons" (reply copyWithout: $:) = newSelector ifTrue: [newSelector := reply asSymbol] ifFalse: [self inform: 'name will be modified']]. self renameScript: oldSelector newSelector: newSelector! ! !Player methodsFor: 'scripts-kernel' stamp: 'sw 2/17/2001 01:05'! scriptEditorFor: aSelector "Answer the receiver's script editor for aSelector" | aScriptEditor | aScriptEditor _ (self class userScriptForPlayer: self selector: aSelector) instantiatedScriptEditorForPlayer: self. aScriptEditor updateToPlayer: self. aScriptEditor bringUpToDate. ^ aScriptEditor! ! !Player methodsFor: 'scripts-kernel' stamp: 'yo 2/16/2005 07:58'! slotInfoButtonHitFor: aGetterSymbol inViewer: aViewer "The user made a gesture asking for slot menu for the given getter symbol in a viewer; put up the menu." | aMenu slotSym aType typeVocab interface selector | slotSym _ Utilities inherentSelectorForGetter: aGetterSymbol. aType _ self typeForSlotWithGetter: aGetterSymbol asSymbol. aMenu _ MenuMorph new defaultTarget: self. interface := aViewer currentVocabulary methodInterfaceAt: aGetterSymbol ifAbsent: [nil]. selector := interface isNil ifTrue: [slotSym asString] ifFalse: [interface selector]. aMenu addTitle: (selector, ' (', (aType asString translated), ')'). (typeVocab _ Vocabulary vocabularyForType: aType) addWatcherItemsToMenu: aMenu forGetter: aGetterSymbol. (self slotInfo includesKey: slotSym) ifTrue: [aMenu add: 'change value type' translated selector: #chooseSlotTypeFor: argument: aGetterSymbol. typeVocab addUserSlotItemsTo: aMenu slotSymbol: slotSym. aMenu add: ('remove "{1}"' translated format: {slotSym}) selector: #removeSlotNamed: argument: slotSym. aMenu add: ('rename "{1}"' translated format: {slotSym}) selector: #renameSlot: argument: slotSym. aMenu addLine]. typeVocab addExtraItemsToMenu: aMenu forSlotSymbol: slotSym. "e.g. Player type adds hand-me-tiles" aMenu add: 'show categories....' translated target: aViewer selector: #showCategoriesFor: argument: aGetterSymbol. self addIdiosyncraticMenuItemsTo: aMenu forSlotSymol: slotSym. aMenu items isEmpty ifTrue: [aMenu add: 'ok' translated action: #yourself]. aMenu popUpForHand: aViewer primaryHand in: aViewer world! ! !Player methodsFor: 'scripts-kernel' stamp: 'mir 7/12/2004 19:36'! tilesToCall: aMethodInterface "Answer a phrase for the non-typed command represented by aMethodInterface." | resultType cmd argType argTile selfTile aPhrase balloonTextSelector aDocString universal | self class namedTileScriptSelectors. resultType _ aMethodInterface resultType. cmd _ aMethodInterface selector. (universal _ self isUniversalTiles) ifTrue: [aPhrase _ self universalTilesForInterface: aMethodInterface] ifFalse: [cmd numArgs == 0 ifTrue: [aPhrase _ PhraseTileMorph new setOperator: cmd type: resultType rcvrType: #Player] ifFalse: ["only one arg supported in classic tiles, so if this is fed with a selector with > 1 arg, results will be very strange" argType _ aMethodInterface typeForArgumentNumber: 1. aPhrase _ PhraseTileMorph new setOperator: cmd type: resultType rcvrType: #Player argType: argType. argTile _ ScriptingSystem tileForArgType: argType. argTile position: aPhrase lastSubmorph position. aPhrase lastSubmorph addMorph: argTile]]. (self slotInfo includesKey: cmd) ifTrue: [balloonTextSelector _ #userSlot]. (self belongsToUniClass and: [self class includesSelector: cmd]) ifTrue: [aDocString _ (self class userScriptForPlayer: self selector: cmd) documentation. aDocString ifNotNil: [aPhrase submorphs second setBalloonText: aDocString] ifNil: [balloonTextSelector _ #userScript]]. (universal ifTrue: [aPhrase submorphs second] ifFalse: [aPhrase operatorTile]) balloonTextSelector: (balloonTextSelector ifNil: [cmd]). universal ifFalse: [selfTile _ self tileToRefer. selfTile position: aPhrase firstSubmorph position. aPhrase firstSubmorph addMorph: selfTile. aPhrase makeAllTilesGreen. aPhrase justGrabbedFromViewer: false]. ^ aPhrase! ! !Player methodsFor: 'scripts-kernel' stamp: 'tk 9/29/2001 22:20'! universalTilesForInterface: aMethodInterface "Return universal tiles for the given method interface. Record who self is." | ms argTile itsSelector aType argList makeSelfGlobal phrase | itsSelector _ aMethodInterface selector. argList _ OrderedCollection new. aMethodInterface argumentVariables doWithIndex: [:anArgumentVariable :anIndex | argTile _ ScriptingSystem tileForArgType: (aType _ aMethodInterface typeForArgumentNumber: anIndex). argList add: (aType == #Player ifTrue: [argTile actualObject] ifFalse: [argTile literal]). "default value for each type"]. ms _ MessageSend receiver: self selector: itsSelector arguments: argList asArray. "For CardPlayers, use 'self'. For others, name me, and use my global name." makeSelfGlobal _ self class officialClass ~~ CardPlayer. phrase _ ms asTilesIn: self class globalNames: makeSelfGlobal. makeSelfGlobal ifFalse: [phrase setProperty: #scriptedPlayer toValue: self]. ^ phrase ! ! !Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:42'! append: aPlayer "Add aPlayer to the list of objects logically 'within' me. This is visually represented by its morph becoming my costume's last submorph. Also allow text to be appended." | aCostume | (aPlayer isNil or: [aPlayer == self]) ifTrue: [^self]. (aPlayer class == Text or: [aPlayer class == String]) ifTrue: [self costume class == TextFieldMorph ifTrue: [^self costume append: aPlayer] ifFalse: [^self]]. (aCostume := self costume topRendererOrSelf) addMorphNearBack: aPlayer costume. aPlayer costume goHome. "assure it's in view" (aCostume isKindOf: PasteUpMorph) ifTrue: [self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:42'! assignStatus: newStatus toAllFor: scriptName "Change the status of my script of the given name to be as specified in me and all of my siblings." | aWorld | (self existingScriptInstantiationForSelector: scriptName) ifNotNilDo: [:scriptInstantiation | scriptInstantiation status: newStatus. scriptInstantiation assignStatusToAllSiblings. ^ (aWorld _ self costume world) ifNotNil: [aWorld updateStatusForAllScriptEditors]]! ! !Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:42'! bounce: soundName "If the receiver's current bounds obtrude beyond the bounds of its container, then 'bounce' it back within the container, and make the indicated sound while doing so" | box bounced aCostume | (aCostume := self costume) ifNil: [^self]. (aCostume owner isNil or: [aCostume owner isHandMorph]) ifTrue: [^self]. box := aCostume owner bounds. bounced := false. aCostume left < box left ifTrue: [self headRight. bounced := true]. aCostume right > box right ifTrue: [self headLeft. bounced := true]. aCostume top < box top ifTrue: [self headDown. bounced := true]. aCostume bottom > box bottom ifTrue: [self headUp. bounced := true]. bounced ifTrue: [^self makeBounceSound: soundName]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 11/11/2001 20:47'! changeScript: scriptName toStatus: statusSymbol "Change the script of the given name to have the given status, and get all relevant script-status controls updated" scriptName ifNil: [^ self]. Symbol hasInterned: scriptName ifTrue: [:sym | self instantiatedUserScriptsDo: [:aScriptInstantiation | aScriptInstantiation selector == sym ifTrue: [aScriptInstantiation status: statusSymbol. aScriptInstantiation updateAllStatusMorphs]]]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/5/2001 11:25'! doButtonAction "Do the button action of my costume" self costume renderedMorph doButtonAction! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 9/2/2001 11:59'! doScript: scriptNameString "On the next tick of the clock, run the given script once" Symbol hasInterned: scriptNameString ifTrue: [:sym | (self class includesSelector: sym) ifTrue: [costume addAlarm: #triggerScript: with: sym after: 1]]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/6/2001 21:13'! fire "Do the button action of my costume" self costume renderedMorph fire! ! !Player methodsFor: 'scripts-standard' stamp: 'mir 6/7/2002 17:08'! forward: dist "Move forward (viz. in the direction of my heading) by the given amount" | rho radians delta didStray p aCostume aPlayfield | (aCostume _ self costume) isInWorld ifFalse: [^ self]. aCostume isWorldOrHandMorph ifTrue: [^ self]. aCostume owner isHandMorph ifTrue: [^ self]. rho _ (aCostume asNumber: dist) asFloat. radians _ (self getHeadingUnrounded asFloat - 90.0) degreesToRadians. delta _ (radians cos @ radians sin) * rho. (aPlayfield _ aCostume pasteUpMorph) fenceEnabled ifTrue: [(aPlayfield bounds containsRect: aCostume bounds) ifFalse: ["If I stray out of the bounds of my playfield, pull me back, but without changing my heading as bounce would. Do nothing if bounce has already corrected the direction." didStray _ false. ((aCostume left < aPlayfield left and: [delta x < 0]) or: [aCostume right > aPlayfield right and: [delta x > 0]]) ifTrue: [delta _ delta x negated @ delta y. didStray _ true]. ((aCostume top < aPlayfield top and: [delta y < 0]) or: [aCostume bottom > aPlayfield bottom and: [delta y > 0]]) ifTrue: [delta _ delta x @ delta y negated. didStray _ true]. (didStray and: [Preferences fenceSoundEnabled]) ifTrue: [aCostume makeFenceSound]]]. "use and record the fractional position" p _ aCostume referencePosition + delta. aCostume referencePosition: p! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 10/3/2004 01:45'! getBackgroundColor "Answer the background color; the costume is presumed to be a TextMorph" ^ self costume renderedMorph backgroundColor ifNil: [Color transparent]! ! !Player methodsFor: 'scripts-standard' stamp: 'yo 3/16/2005 15:43'! goToRightOf: aPlayer "Place the object so that it lies directly to the right of the given object" | hisCostume aCostume | (aPlayer isNil or: [aPlayer == self]) ifTrue: [^self]. (hisCostume := aPlayer costume) isInWorld ifFalse: [^self]. aCostume := self costume. aCostume isWorldMorph ifTrue: [^ self]. aCostume owner == hisCostume owner ifFalse: [hisCostume owner addMorphFront: aCostume]. aCostume position: hisCostume bounds rightCenter - (0 @ (aCostume height // 2))! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/3/2002 23:09'! include: anObject "Add the object to my content" ^ self append: anObject! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 10/3/2004 01:27'! includeAtCursor: aPlayer "Add aPlayer to the list of objects logically 'within' me, at my current cursor position. ." | aCostume | (aPlayer isNil or: [aPlayer == self]) ifTrue: [^self]. (aPlayer class == Text or: [aPlayer class == String]) ifTrue: [^ self costume class == TextFieldMorph ifTrue: [self costume append: aPlayer] ifFalse: [self]]. aCostume := self costume topRendererOrSelf. aPlayer costume goHome. "assure it's in view" (aCostume isKindOf: PasteUpMorph) ifTrue: [aCostume addMorph: aPlayer costume asElementNumber: self getCursor. aCostume invalidRect: aCostume bounds] ifFalse: [aCostume addMorphBack: aPlayer. self setCursor: aCostume submorphs size]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/18/2003 02:57'! insertCharacters: aString "Insert the given characters at my current cursor position" self costume renderedMorph insertCharacters: aString! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/18/2003 02:57'! insertContentsOf: aPlayer "Insert the string contents of the given player at my given cursor position" self costume renderedMorph insertContentsOf: aPlayer! ! !Player methodsFor: 'scripts-standard' stamp: 'gk 2/23/2004 20:51'! loadSound: soundName | snd | snd _ SoundService default soundNamed: soundName. snd ifNotNil: [self sendMessageToCostume: #loadSound: with: snd]. ! ! !Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:43'! makeNewDrawingIn: paintPlacePlayer | paintPlace | ((paintPlacePlayer isNil or: [((paintPlace := paintPlacePlayer costume) isKindOf: PasteUpMorph) not]) or: [paintPlace isInWorld not]) ifTrue: [^self inform: 'Error: not a plausible place in which to make a new drawing']. paintPlace makeNewDrawingWithin! ! !Player methodsFor: 'scripts-standard' stamp: 'dgd 8/8/2003 22:15'! moveToward: aPlayer "Move a standard amount in the direction of the given player. If the object has an instance variable named 'speed', the speed of the motion will be governed by that value" self turnToward: aPlayer. self forward: self getSpeed! ! !Player methodsFor: 'scripts-standard' stamp: 'tak 1/21/2005 12:08'! overlapsAny: aPlayer "Answer true if my costume overlaps that of aPlayer, or any of its siblings (if aPlayer is a scripted player) or if my costume overlaps any morphs of the same class (if aPlayer is unscripted)." | possibleCostumes itsCostume itsCostumeClass myShadow | (self ~= aPlayer and: [self overlaps: aPlayer]) ifTrue: [^ true]. possibleCostumes := IdentitySet new. aPlayer belongsToUniClass ifTrue: [aPlayer class allSubInstancesDo: [:anInstance | (anInstance ~~ aPlayer and: [itsCostume := anInstance costume. (itsCostume bounds intersects: costume bounds) and: [itsCostume world == costume world]]) ifTrue: [possibleCostumes add: itsCostume]]] ifFalse: [itsCostumeClass := aPlayer costume class. self costume world presenter allExtantPlayers do: [:ep | ep costume ifNotNilDo: [:ea | (ea class == itsCostumeClass and: [ea bounds intersects: costume bounds]) ifTrue: [possibleCostumes add: ea]]]]. possibleCostumes isEmpty ifTrue: [^ false]. myShadow := costume shadowForm. ^ possibleCostumes anySatisfy: [:m | m overlapsShadowForm: myShadow bounds: costume fullBounds]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:23'! pauseAll: scriptName "Change the status of my script of the given name to be #paused in me and all of my siblings." self assignStatus: #paused toAllFor: scriptName! ! !Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:15'! performScriptIfCan: scriptNameString "If I understand the given script name, perform it now" ^Symbol hasInterned: scriptNameString ifTrue: [:sym | (self class includesSelector: sym) ifTrue: [self triggerScript: sym]]! ! !Player methodsFor: 'scripts-standard' stamp: 'dgd 2/22/2003 13:44'! prepend: aPlayer "Add aPlayer to the list of objects logically 'within' me. This is visually represented by its morph becoming my costume's first submorph. Also allow text to be prepended." | aCostume | (aPlayer isNil or: [aPlayer == self]) ifTrue: [^self]. (aPlayer class == Text or: [aPlayer class == String]) ifTrue: [^ self costume class == TextFieldMorph ifTrue: [self costume prepend: aPlayer] ifFalse: [self]]. (aCostume := self costume topRendererOrSelf) addMorphFront: aPlayer costume. aPlayer costume goHome. "assure it's in view" (aCostume isKindOf: PasteUpMorph) ifTrue: [self setCursor: (aCostume submorphs indexOf: aPlayer costume)]! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 10/3/2004 01:32'! setBackgroundColor: aColor "Set the background color; the costume is presumed to be a text morph." self costume renderedMorph backgroundColor: aColor! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 06:59'! startAll: scriptName "Change the status of my script of the given name to be #ticking in me and all of my siblings." self assignStatus: #ticking toAllFor: scriptName! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 9/4/2001 07:24'! stopAll: scriptName "Change the status of my script of the given name to be #normal in me and all of my siblings." self assignStatus: #normal toAllFor: scriptName! ! !Player methodsFor: 'scripts-standard' stamp: 'sw 2/20/2003 13:14'! tellAllContents: aMessageSelector "Send the given message selector to all the content players within the receiver's morph" costume renderedMorph tellAllContents: aMessageSelector! ! !Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:39'! tellAllSiblings: aMessageSelector "Send the given message selector to all my sibling instances, but not to myself" Symbol hasInterned: aMessageSelector ifTrue: [ :sel | self belongsToUniClass ifTrue: [self class allSubInstancesDo: [:anInstance | anInstance ~~ self ifTrue: [ anInstance triggerScript: sel ]]] ifFalse: [(sel ~~ #emptyScript) ifTrue: [ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName) ]]]! ! !Player methodsFor: 'scripts-standard' stamp: 'nk 8/21/2004 12:42'! tellSelfAndAllSiblings: aMessageSelector "Send the given message selector to all my sibling instances, including myself" Symbol hasInterned: aMessageSelector ifTrue: [ :sel | self belongsToUniClass ifTrue: [self class allSubInstancesDo: [:anInstance | anInstance triggerScript: sel ]] ifFalse: [(sel ~~ #emptyScript) ifTrue: [ScriptingSystem reportToUser: ('Cannot "tell" ', aMessageSelector, ' to ', self externalName) ]]]! ! !Player methodsFor: 'scripts-standard' stamp: 'yo 3/16/2005 15:44'! turnToward: aPlayer "Turn to the direction of the given player." | angle aCostume | (aPlayer == nil or: [aPlayer == self]) ifTrue: [^ self]. aCostume _ self costume. aCostume isWorldMorph ifTrue: [^ self]. (aCostume bounds intersects: aPlayer costume bounds) ifTrue: [^ self]. angle _ aCostume referencePosition bearingToPoint: aPlayer costume referencePosition. self setHeading: angle. ! ! !Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'! * aNumber "Treating Players like vectors, return a new Player that is myself scaled by the number" | new | new _ costume usableSiblingInstance player. new setX: self getX * aNumber asPoint x. new setY: self getY * aNumber asPoint y. ^ new ! ! !Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'! + aPlayer "Treating Players like vectors, add aPlayer to me and return a new Player" | new | new _ costume usableSiblingInstance player. new setX: self getX + aPlayer asPoint x. new setY: self getY + aPlayer asPoint y. ^ new! ! !Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:46'! - aPlayer "Treating Players like vectors, subtract aPlayer from me and return a new Player" | new | new _ costume usableSiblingInstance player. new setX: self getX - aPlayer asPoint x. new setY: self getY - aPlayer asPoint y. ^ new! ! !Player methodsFor: 'scripts-vector' stamp: 'nk 9/25/2003 11:45'! / aNumber "Treating Players like vectors, return a new Player that is myself divided by the number" | new | new _ costume usableSiblingInstance player. new setX: self getX / aNumber asPoint x. new setY: self getY / aNumber asPoint y. ^ new ! ! !Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:41'! asPoint ^ self getX @ self getY! ! !Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:46'! decr: aPlayer "Treating Players like vectors, subtract aPlayer from me" self setX: self getX - aPlayer asPoint x. self setY: self getY - aPlayer asPoint y.! ! !Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:51'! dividedBy: aNumber "Treating Players like vectors, divide myself by aNumber" self setX: self getX / aNumber asPoint x. self setY: self getY / aNumber asPoint y. ! ! !Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:49'! incr: aPlayer "Treating Players like vectors, add aPlayer to me" self setX: self getX + aPlayer asPoint x. self setY: self getY + aPlayer asPoint y. ! ! !Player methodsFor: 'scripts-vector' stamp: 'tk 8/18/2001 22:51'! multBy: aNumber "Treating Players like vectors, scale myself by aNumber" self setX: self getX * aNumber asPoint x. self setY: self getY * aNumber asPoint y. ! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:18'! bookEmbodied "Answer the book embodied by the receiver's costume; usually this is directly the receiver's costume, but in case it is not, we look up the owner chain for one. This allows page-number messages to be sent to a *page* of the stack, as Alan is wont to do, and have them still find their way to the right place" | aMorph | ^ ((aMorph _ self costume renderedMorph) isKindOf: BookMorph) ifTrue: [aMorph] ifFalse: [aMorph ownerThatIsA: BookMorph]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'! getBaseGraphic "Answer a form representing the receiver's base graphic" | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph baseGraphic] ifFalse: [aMorph imageForm]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 7/5/2004 22:47'! getBorderColor "Answer the border color of my costume" ^ costume renderedMorph borderStyle color ifNil: [costume renderedMorph borderStyle baseColor]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 10:02'! getBorderStyle "Answer the border style" ^ costume renderedMorph borderStyle style! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 11:33'! getBorderWidth "Answer the border width of my costume" ^ costume renderedMorph borderStyle width! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:31'! getCardNumber "Answer the current card number" | aStack | ^ (aStack _ self stackEmbodied) cardNumberOf: aStack currentCard! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:31'! getCellInset "Getter for costume's cellInset" ^ costume cellInset! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 18:09'! getCharacterAtCursor "Answer the value of the text cursor" | aLoc aTextMorph aString | aLoc _ (aTextMorph _ self costume renderedMorph) cursor. aString _ aTextMorph text string. ^ (aString at: aLoc ifAbsent: ['·']) asString! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 10:22'! getClipSubmorphs "Getter for costume's clipSubmorphs" ^ costume renderedMorph clipSubmorphs! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:34'! getColor "Answer the color of my costume. If it uses a gradient fill, answer the first color." | aFillStyle aMorph | ^ (aFillStyle _ (aMorph _ self costume renderedMorph) fillStyle) isGradientFill ifTrue: [aFillStyle colorRamp first value] ifFalse: [aMorph color]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'! getCostume "Answer a form representing the receiver's primary graphic. An earlier wording, disused but may persist in preexisting scripts." | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph form] ifFalse: [aMorph imageForm]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'! getCostumeAtCursor "Answer the form representing the object at the current cursor. An earlier wording, disused but may persist in preexisting scripts" | anObject aMorph | anObject _ self getValueFromCostume: #valueAtCursor. ^ anObject == 0 "weird return from GraphMorph" ifTrue: [ScriptingSystem formAtKey: #Paint] ifFalse: [((aMorph _ anObject renderedMorph) isSketchMorph) ifTrue: [aMorph form] ifFalse: [anObject imageForm]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 11:46'! getCount "Answer the number of elements" ^ self costume renderedMorph elementCount! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 3/17/2001 15:11'! getDistance "Answer distance from the origin to the objet's position" ^ (self getX @ self getY) r! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'! getDragEnabled "Getter for costume's dragEnabled" ^ costume dragEnabled! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'! getDropEnabled "Getter for costume's dropEnabled" ^ costume dropEnabled! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/12/2005 14:43'! getDropShadow "Getter for costume's hasDropShadow" ^ costume renderedMorph hasDropShadow! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:43'! getFirstElement "Answer a player representing the receiver's costume's first submorph" | itsMorphs | ^(itsMorphs := costume submorphs) notEmpty ifFalse: [costume presenter standardPlayer] ifTrue: [itsMorphs first assuredPlayer]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'! getGraphic "Answer a form representing the receiver's primary graphic" | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph form] ifFalse: [aMorph isPlayfieldLike ifTrue: [aMorph backgroundForm] ifFalse: [aMorph imageForm]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:00'! getGraphicAtCursor "Answer the form representing the object at the current cursor" | anObject aMorph | anObject _ self getValueFromCostume: #valueAtCursor. ^ anObject == 0 "weird return from GraphMorph" ifTrue: [ScriptingSystem formAtKey: #Paint] ifFalse: [((aMorph _ anObject renderedMorph) isSketchMorph) ifTrue: [aMorph form] ifFalse: [aMorph isPlayfieldLike ifTrue: [aMorph backgroundForm] ifFalse: [aMorph imageForm]]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'! getHResizing "Getter for costume's hResizing" ^ costume hResizing! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 9/15/2002 12:03'! getHeading "Answer the heading of the object, *formerly* ;-) always given as a whole number" ^ self getHeadingUnrounded "rounded"! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 9/17/2002 10:50'! getHeadingTheta "Answer the angle, in degrees, between the positive x-axis and the receiver's heading vector" | aHeading excess normalized | aHeading _ self getHeadingUnrounded. excess _ aHeading - (aHeading rounded). normalized _ (450 - aHeading) \\ 360. ^ normalized + excess! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 8/6/2001 19:38'! getHolder "Answer the player belonging to my costume's container" ^ costume topRendererOrSelf owner topRendererOrSelf assuredPlayer! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:39'! getIsLocked "Answer whether the receiver's costume is locked" ^ costume isLocked! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 8/10/2004 12:15'! getLastCharacter "Answer my costume's last character." ^ costume renderedMorph getLastCharacter! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 10/13/2004 11:30'! getLastKeystroke "Answer the last keystroke fielded" ^ self getValueFromCostume: #lastKeystroke! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'! getLayoutInset "Getter for costume's layoutInset" ^ costume layoutInset! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 3/10/2004 12:15'! getLength "Answer the length of the object" | aLength cost | ((cost _ self costume) isLineMorph) "annoying special case" ifTrue: [^ cost unrotatedLength]. aLength _ cost renderedMorph height. "facing upward when unrotated" cost isRenderer ifTrue: [aLength _ aLength * cost scaleFactor]. ^ aLength! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:31'! getListCentering "Getter for costume's listCentering" ^ costume listCentering! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:30'! getListDirection "Getter for costume's listDirection" ^ costume listDirection! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 2/12/2005 20:18'! getMouseX ^ self costume renderedMorph mouseX! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 2/12/2005 20:26'! getMouseY ^ self costume renderedMorph mouseY. ! ! !Player methodsFor: 'slot getters/setters' stamp: 'tak 1/26/2005 14:58'! getNewClone "Answer a new player of the same class as the receiver, with a costume much like mine" | clone | clone _ costume usableSiblingInstance. costume pasteUpMorph ifNotNilDo: [:parent | parent addMorph: clone]. ^ clone player ! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:31'! getPageNumber "Answer the current page number of my book" | aBook | ^ (aBook _ self bookEmbodied) pageNumberOf: aBook currentPage! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:11'! getPosition "Answer the numeric value contained in my costume" ^ costume renderedMorph getPosition! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:32'! getRadialGradientFill "Geter for costume's useGradientFill" | aStyle | ^ (aStyle _ costume renderedMorph fillStyle) isGradientFill and: [aStyle isRadialFill]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/15/2001 16:34'! getResistsRemoval "Answer whether the receiver is marked to resist removal" ^ costume resistsRemoval! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 7/14/2004 21:37'! getRotationStyle "Answer the symbol representing the rotation style" ^ (#(rotate #'do not rotate' #'flip left right' #'flip up down') at: (#(normal none leftRight upDown ) indexOf: costume renderedMorph rotationStyle))! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 2/15/2002 02:37'! getScaleFactor "Answer the scale factor of the object" ^ self costume scaleFactor! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:12'! getSecondColor "Getter for costume's second color, if it's using gradient fill; sonst answers white." | aFillStyle | ^ (aFillStyle _ costume renderedMorph fillStyle) isGradientFill ifTrue: [aFillStyle colorRamp last value] ifFalse: [Color white]! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/14/2005 10:38'! getShadowColor "Getter for costume's shadowColor" ^ costume renderedMorph shadowColor! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:30'! getSticky "Getter for costume's isSticky" ^ costume isSticky! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 2/18/2003 02:20'! getStringContents "Answer the String contents" ^ self costume renderedMorph getCharacters! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 21:40'! getSubtitlesFileName "Answer the subtitlesFileName in my costume" ^ costume renderedMorph getSubtitlesFileName! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 3/17/2001 15:10'! getTheta "Answer the angle between the positive x-axis and the line connecting the origin and the object's position" ^ (self getX @ self getY) degrees! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:33'! getUseGradientFill "Geter for costume's useGradientFill" ^ costume renderedMorph fillStyle isGradientFill! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:29'! getVResizing "Getter for costume's vResizing" ^ costume vResizing! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 18:26'! getVideoFileName "Answer the videoFileName in my costume" ^ costume renderedMorph getVideoFileName! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:13'! getVolume "Answer the numeric value contained in my costume" ^ costume renderedMorph getVolume! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 3/10/2004 12:15'! getWidth "Answer the width of the object" | aWidth cost | ((cost _ self costume) isLineMorph) "annoying special case" ifTrue: [^ cost unrotatedWidth]. aWidth _ cost renderedMorph width. "facing upward when unrotated" cost isRenderer ifTrue: [aWidth _ aWidth * cost scaleFactor]. ^ aWidth! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:27'! getWrapDirection "Getter for costume's wrapDirection" ^ costume wrapDirection! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 9/25/2001 03:38'! setActWhen: val "Tell the receiver's costume (hopefully a button!!) to set its actWhen parameter as indicated" costume renderedMorph actWhen: val! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'! setBaseGraphic: aGraphic "Set the base graphic" | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph baseGraphic: aGraphic]! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55'! setBorderColor: aColor "Set the border color as requested" costume renderedMorph borderColor: aColor! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/26/2001 16:20'! setBorderStyle: aSymbol "Set the border style of my costume" costume renderedMorph setBorderStyle: aSymbol! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 4/13/2004 18:55'! setBorderWidth: aWidth "Set the border width to the given number" costume renderedMorph borderWidth: aWidth! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'! setBottom: w "Set the bottom coordinate (cartesian sense) of the object as requested" | topLeftNow cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. topLeftNow _ cost cartesianBoundsTopLeft. ^ cost bottom: cost top + topLeftNow y - w ! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:32'! setCardNumber: aNumber "Go to the given card number" self stackEmbodied goToCardNumber: aNumber! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'! setCellInset: aValue "Setter for costume's cellInset" costume cellInset: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 2/17/2003 17:35'! setCharacterAtCursor: aCharOrString "Insert the given character at my cursor position" | aLoc aTextMorph aString charToUse | aLoc _ (aTextMorph _ self costume renderedMorph) cursor. charToUse _ (aString _ aCharOrString asString) size > 0 ifTrue: [aString first] ifFalse: ['·']. aTextMorph paragraph replaceFrom: aLoc to: aLoc with: charToUse asString asText displaying: true. aTextMorph updateFromParagraph ! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 10:23'! setClipSubmorphs: aBoolean "Setter for costume's clipSubmorphs" costume renderedMorph clipSubmorphs: aBoolean. costume renderedMorph changed! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:27'! setColor: aColor "Set the color of the graphic as requested" | aFillStyle aMorph | (aFillStyle _ (aMorph _ self costume renderedMorph) fillStyle) isGradientFill ifTrue: [aFillStyle firstColor: aColor forMorph: aMorph hand: nil] ifFalse: [aMorph color: aColor]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 5/4/2001 06:06'! setColorUnder: aValue "Provide a soft landing for old readouts that may try to send this"! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'! setCostume: aForm "Set the receiver's graphic as indicated. An earlier wording, disused but may persist in preexisting scripts." | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph form: aForm] ifFalse: ["what to do?"]! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:35'! setDistance: aDistance "Set the object's distance from the origin to be as indicated, preserving its angle." | cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. cost cartesianXY: (Point r: aDistance degrees: self getTheta)! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'! setDragEnabled: aValue "Setter for costume's dragEnabled" costume dragEnabled: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'! setDropEnabled: aValue "Setter for costume's dropEnabled" costume dropEnabled: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 3/15/2005 18:23'! setDropShadow: aValue "Setter for costume's dropShadow" | aMorph | (aMorph _ costume renderedMorph) hasDropShadow ~~ aValue ifTrue: [aMorph toggleDropShadow]! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/22/2003 13:45'! setFirstElement: aPlayer "Caution - this is a replacement operation!! Replace the receiver's costume's first element with the morph represented by aPlayer" | aCostume | (aPlayer == self or: [(aCostume := self costume) submorphs isEmpty]) ifTrue: [^self]. costume replaceSubmorph: aCostume submorphs first by: aPlayer costume! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 6/12/2004 10:02'! setGraphic: aForm "Set the receiver's graphic as indicated" | aMorph | ^ ((aMorph _ costume renderedMorph) isSketchMorph) ifTrue: [aMorph form: aForm] ifFalse: [aMorph isPlayfieldLike ifTrue: [aMorph backgroundForm: aForm] ifFalse: ["what to do?"]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 09:55'! setHResizing: aValue "Setter for costume's hResizing" costume hResizing: aValue asSymbol! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:34'! setHeading: newHeading "Set the heading as indicated" | aCostume | aCostume _ self costume. aCostume isWorldMorph ifTrue: [^ self]. (newHeading closeTo: aCostume heading) ifTrue: [^ self]. aCostume heading: newHeading. aCostume _ self costume. "in case we just got flexed for no apparent reason" (aCostume isFlexMorph and:[aCostume hasNoScaleOrRotation]) ifTrue: [aCostume removeFlexShell]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 9/17/2002 10:17'! setHeadingTheta: anAngle "Set the heading theta" self setHeading: (450 - anAngle)! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/10/2001 00:40'! setIsLocked: aBoolean "Set my costume's isLocked" costume lock: aBoolean! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 8/10/2004 00:54'! setLastCharacter: aChar "Set my costume's last character to the indicated value, usually a string of length one." costume renderedMorph setLastCharacter: aChar! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 10/13/2004 11:30'! setLastKeystroke: aString "Set the last keystroke fielded" self setCostumeSlot: #lastKeystroke: toValue: aString! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:34'! setLayoutInset: aValue "Setter for costume's layoutInset" costume layoutInset: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'! setLeft: w "Set the object's left coordinate as indicated" | topLeftNow cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. topLeftNow _ cost cartesianBoundsTopLeft. ^ cost left: cost left - topLeftNow x + w ! ! !Player methodsFor: 'slot getters/setters' stamp: 'nk 3/10/2004 12:15'! setLength: aLength "Set the length of the receiver." | cost lengthToUse | ((cost _ self costume) isLineMorph) ifTrue: [^ cost unrotatedLength: aLength]. lengthToUse _ cost isRenderer ifTrue: [aLength / cost scaleFactor] ifFalse: [aLength]. cost renderedMorph height: lengthToUse! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'! setListCentering: val "Setter for costume's listCentering" costume listCentering: val! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'! setListDirection: aValue "Setter for costume's listDirection" costume listDirection: aValue asSymbol! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/7/2002 13:34'! setPageNumber: aNumber "Set the page number of my book as indicated." self bookEmbodied goToPage: aNumber! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:11'! setPosition: amt "Set the receiver's numeric value to the amount. This is passed on to the costume" costume renderedMorph setPosition: amt! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 08:51'! setRadialGradientFill: aBoolean "Setter for costume's radialGradientFill" | aStyle | (aStyle _ costume renderedMorph fillStyle) isGradientFill ifTrue: [aStyle isRadialFill ~~ aBoolean ifTrue: [aStyle radial: aBoolean. costume renderedMorph changed]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/15/2001 16:34'! setResistsRemoval: aBoolean "Set the resistsRemoval property" ^ costume resistsRemoval: aBoolean! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'! setRight: w "Set the right coordinate to the given value" | topLeftNow cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. topLeftNow _ cost cartesianBoundsTopLeft. ^ cost right: cost left - topLeftNow x + w ! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 7/14/2004 21:35'! setRotationStyle: aStyleSymbol "Set the rotation style to the indicated symbol; the external symbols seen are different, as you'll observe..." costume renderedMorph rotationStyle: (#(normal none leftRight upDown ) at: (#(rotate #'do not rotate' #'flip left right' #'flip up down') indexOf: aStyleSymbol))! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:33'! setScaleFactor: aNumber "Set the scale factor to be the given value" | cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. cost scaleFactor: ((aNumber asFloat max: 0.1) min: 10.0)! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 12/9/2001 23:55'! setSecondColor: aColor "Setter for costume's second color, if it's using gradient fill; if not, does nothing" | aFillStyle aMorph | ^ (aFillStyle _ (aMorph _ costume renderedMorph) fillStyle) isGradientFill ifTrue: [aFillStyle lastColor: aColor forMorph: aMorph hand: ActiveHand]! ! !Player methodsFor: 'slot getters/setters' stamp: 'tak 3/15/2005 11:17'! setShadowColor: aValue "Setter for costume's shadowColor" costume renderedMorph shadowColor: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:33'! setSticky: val "Setter for costume's sticky" costume sticky: val! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 21:40'! setSubtitlesFileName: aString "Set my costume's subtitlesFileName as indicated" costume renderedMorph setSubtitlesFileName: aString! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:35'! setTheta: aTheta "Set the object's position such that its rho is unchanged but the angle between the positive x-axis and the vector connecting the origin and the object's position is as given." | cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. cost cartesianXY: (Point r: self getDistance degrees: aTheta)! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:32'! setTop: w "Set the top coordinate as indicated, using cartesian sense" | topLeftNow cost | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. topLeftNow _ cost cartesianBoundsTopLeft. ^ cost top: cost top + topLeftNow y - w! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/14/2005 13:45'! setUseGradientFill: aBoolean "Setter for costume's useGradientFill" costume renderedMorph fillStyle isGradientFill ifTrue: [aBoolean ifFalse: [costume renderedMorph useSolidFill]] ifFalse: [aBoolean ifTrue: [costume renderedMorph useGradientFill]]! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 09:55'! setVResizing: aValue "Setter for costume's vResizing" costume vResizing: aValue asSymbol! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 3/8/2004 18:24'! setVideoFileName: aString "Set my costume's videoFileName as indicated" costume renderedMorph setVideoFileName: aString! ! !Player methodsFor: 'slot getters/setters' stamp: 'dgd 2/15/2004 21:15'! setVolume: amt "Set the receiver's numeric value to the amount. This is passed on to the costume" costume renderedMorph setVolume: amt! ! !Player methodsFor: 'slot getters/setters' stamp: 'yo 3/16/2005 15:30'! setWidth: aWidth "Set the width" | cost widthToUse | cost _ self costume. cost isWorldMorph ifTrue: [^ self]. cost isLineMorph ifTrue: [^ cost unrotatedWidth: aWidth]. widthToUse _ cost isRenderer ifTrue: [aWidth / cost scaleFactor] ifFalse: [aWidth]. cost renderedMorph width: widthToUse! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/16/2001 07:32'! setWrapDirection: aValue "Setter for costume's wrapDirection" costume wrapDirection: aValue! ! !Player methodsFor: 'slot getters/setters' stamp: 'di 9/12/2001 20:49'! setX: val "Set the x coordinate as indicated" | aCostume | (aCostume _ self costume) isInWorld ifFalse: [^ self]. aCostume isWorldOrHandMorph ifTrue: [^ self]. aCostume owner isHandMorph ifTrue: [^ self]. ^ aCostume x: val! ! !Player methodsFor: 'slot getters/setters' stamp: 'di 9/12/2001 20:51'! setY: val "Set the y coordinate as indicated" | aCostume | (aCostume _ self costume) isInWorld ifFalse: [^ self]. aCostume isWorldOrHandMorph ifTrue: [^ self]. aCostume owner isHandMorph ifTrue: [^ self]. ^ aCostume y: val! ! !Player methodsFor: 'slot getters/setters' stamp: 'sw 11/4/2002 19:31'! stackEmbodied "Answer the stack embodied by the receiver's costume; usually this is directly the receiver's costume, but in case it is not, we look up the owner chain for one. This allows card-number messages to be sent to a *page* of the stack, as Alan is wont to do, and have them still find their way to the right place" | aMorph | ^ ((aMorph _ self costume renderedMorph) isKindOf: StackMorph) ifTrue: [aMorph] ifFalse: [aMorph ownerThatIsA: StackMorph]! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 12/6/2001 21:57'! absorbBackgroundDataFrom: aLine forInstanceVariables: slotNames "Fill my background fields from the substrings in a tab-delimited line of data. At the moment this only really cateres to string-valued items" slotNames doWithIndex: [:aSlotName :anIndex | aLine do: [:aValue | self instVarNamed: aSlotName put: aValue] toFieldNumber: anIndex]! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 23:58'! categories "Answer a list of categories appropriate to the the receiver and its costumes" | aList | (self hasCostumeThatIsAWorld) ifTrue: [^ self categoriesForWorld]. aList _ OrderedCollection new. self slotNames notEmpty ifTrue: [aList add: ScriptingSystem nameForInstanceVariablesCategory]. aList addAll: costume categoriesForViewer. aList remove: ScriptingSystem nameForScriptsCategory ifAbsent: []. aList add: ScriptingSystem nameForScriptsCategory after: aList first. ^ aList! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 3/3/2004 00:00'! categoriesForVocabulary: aVocabulary "Answer a list of categories appropriate to the receiver and its costumes, in the given Vocabulary" | aList | self hasCostumeThatIsAWorld ifTrue: [aList _ self categoriesForWorld] ifFalse: [aList _ OrderedCollection new. self slotNames ifNotEmpty: [aList add: ScriptingSystem nameForInstanceVariablesCategory]. aList addAll: costume categoriesForViewer]. aVocabulary addCustomCategoriesTo: aList. aList remove: ScriptingSystem nameForScriptsCategory ifAbsent: []. aList add: ScriptingSystem nameForScriptsCategory after: aList first. ^ aList! ! !Player methodsFor: 'slots-kernel' stamp: 'nk 10/13/2004 11:34'! categoriesForWorld "Answer the list of categories given that the receiver is the Player representing a World" | aList | aList _ #(#'color & border' #'pen trails' playfield collections #'stack navigation') asOrderedCollection. aList addFirst: ScriptingSystem nameForScriptsCategory. aList addFirst: ScriptingSystem nameForInstanceVariablesCategory. aList add: #input. ^ aList! ! !Player methodsFor: 'slots-kernel' stamp: 'yo 8/1/2004 02:04'! methodInterfacesForInstanceVariablesCategoryIn: aVocabulary "Return a collection of methodInterfaces for the instance-variables category. The vocabulary parameter, at present anyway, is not used." | aList anInterface itsSlotName | aList _ OrderedCollection new. self slotInfo associationsDo: [:assoc | anInterface _ MethodInterface new. itsSlotName _ assoc key. anInterface wording: itsSlotName; helpMessage: 'a variable defined by this object' translated. anInterface selector: (Utilities getterSelectorFor: itsSlotName) type: assoc value type setter: (Utilities setterSelectorFor: itsSlotName). anInterface setToRefetch. aList add: anInterface]. ^ aList! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 5/29/2001 13:57'! typeForSlot: aSlotName "Answer the data type for values of the instance variable of the given name" | getter | (self slotInfo includesKey: aSlotName) ifTrue: [^ (self slotInfoAt: aSlotName) type]. getter _ (aSlotName beginsWith: 'get') ifTrue: [aSlotName] ifFalse: [Utilities getterSelectorFor: aSlotName]. ^ (self currentVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 5/24/2001 14:29'! typeForSlot: aSlotName vocabulary: aVocabulary "Answer the data type for values of the instance variable of the given name. Presently has no senders but retained for a while..." | getter inherentSelector | inherentSelector _ Utilities inherentSelectorForGetter: aSlotName. (self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type]. getter _ (aSlotName beginsWith: 'get') ifTrue: [aSlotName] ifFalse: [Utilities getterSelectorFor: aSlotName]. ^ (aVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aSlotName]) resultType! ! !Player methodsFor: 'slots-kernel' stamp: 'nk 10/14/2004 10:56'! typeForSlotWithGetter: aGetter "Answer the data type for values of the instance variable of the given name" | getter inherentSelector | (#(color:sees: seesColor: touchesA: overlaps: overlapsAny:) includes: aGetter) ifTrue: [^ #Boolean]. "Annoying special cases" inherentSelector _ Utilities inherentSelectorForGetter: aGetter. (self slotInfo includesKey: inherentSelector) ifTrue: [^ (self slotInfoAt: inherentSelector) type]. getter _ (aGetter beginsWith: 'get') ifTrue: [aGetter] ifFalse: [Utilities getterSelectorFor: aGetter]. ^ (Vocabulary eToyVocabulary methodInterfaceAt: getter ifAbsent: [self error: 'Unknown slot name: ', aGetter]) resultType! ! !Player methodsFor: 'slots-kernel' stamp: 'sw 10/16/2004 03:55'! usableMethodInterfacesIn: methodInterfaceList "Filter the list given by methodInterfaceList, to remove items inappropriate to the receiver" self hasCostumeThatIsAWorld ifTrue: "Formerly we had been hugely restrictive here, but let's try the other extreme for a while..." [^ methodInterfaceList reject: [:anInterface | #() includes: anInterface selector]]. self hasAnyBorderedCostumes ifTrue: [^ methodInterfaceList]. ^ self hasOnlySketchCostumes ifTrue: [methodInterfaceList select: [:anInterface | (#(getColor getSecondColor getBorderColor getBorderWidth getBorderStyle getRoundedCorners getUseGradientFill getRadialGradientFill ) includes: anInterface selector) not]] ifFalse: [methodInterfaceList select: [:anInterface | (#(getBorderColor getBorderWidth) includes: anInterface selector) not]]! ! !Player methodsFor: 'slots-user' stamp: 'yo 7/2/2004 19:02'! addInstanceVariable "Offer the user the opportunity to add an instance variable, and if he goes through with it, actually add it." | itsName initialValue typeChosen usedNames initialAnswer setterSelector originalString | usedNames _ self class instVarNames. initialAnswer _ Utilities keyLike: ('var' translated, (usedNames size + 1) asString) satisfying: [:aKey | (usedNames includes: aKey) not]. originalString _ FillInTheBlank request: 'name for new variable: ' translated initialAnswer: initialAnswer. originalString isEmptyOrNil ifTrue: [^ self]. itsName _ ScriptingSystem acceptableSlotNameFrom: originalString forSlotCurrentlyNamed: nil asSlotNameIn: self world: self costume world. itsName size == 0 ifTrue: [^ self]. self assureUniClass. typeChosen _ self initialTypeForSlotNamed: itsName. self slotInfo at: itsName put: (SlotInformation new initialize type: typeChosen). initialValue _ self initialValueForSlotOfType: typeChosen. self addInstanceVarNamed: itsName withValue: initialValue. self class compileAccessorsFor: itsName. setterSelector _ Utilities setterSelectorFor: itsName. (self class allSubInstances copyWithout: self) do: [:anInstance | anInstance perform: setterSelector with: initialValue]. self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory! ! !Player methodsFor: 'slots-user' stamp: 'sw 2/6/2003 18:04'! addInstanceVariableNamed: nameSymbol type: typeChosen value: aValue "Add an instance variable of the given name and type, and initialize it to have the given value" | initialValue setterSelector | self assureUniClass. self slotInfo at: nameSymbol put: (SlotInformation new initialize type: typeChosen). initialValue _ self initialValueForSlotOfType: typeChosen. self addInstanceVarNamed: nameSymbol withValue: aValue. self class compileAccessorsFor: nameSymbol. setterSelector _ Utilities setterSelectorFor: nameSymbol. (self class allSubInstances copyWithout: self) do: [:anInstance | anInstance perform: setterSelector with: initialValue]. self updateAllViewersAndForceToShow: ScriptingSystem nameForInstanceVariablesCategory ! ! !Player methodsFor: 'slots-user' stamp: 'NS 1/28/2004 14:47'! addSpecialSetter: selector | instVar code | "For the special setters, fooIncreaseBy:, fooDecreaseBy:, fooMultiplyBy:, add a method that does them." self assureUniClass. instVar _ (selector allButLast: 11) asLowercase. "all three are 11 long!!" (self respondsTo: ('set', instVar capitalized, ':') asSymbol) ifFalse: [^ false]. code _ String streamContents: [:strm | strm nextPutAll: selector, ' amount'; crtab. strm nextPutAll: 'self set', instVar capitalized, ': (self get', instVar capitalized; space. (selector endsWith: 'IncreaseBy:') ifTrue: [strm nextPut: $+]. (selector endsWith: 'DecreaseBy:') ifTrue: [strm nextPut: $-]. (selector endsWith: 'MultiplyBy:') ifTrue: [strm nextPut: $*]. strm nextPutAll: ' amount)']. self class compileSilently: code classified: 'access' notifying: nil. ^ true ! ! !Player methodsFor: 'slots-user' stamp: 'sw 1/6/2005 01:32'! allPossibleWatchersFromWorld "Answer a list of all UpdatingStringMorphs, PlayerReferenceReadouts, ThumbnailMorphs, and UpdatingReferenceMorphs in the Active world and its hidden book pages, etc., which have me or any of my siblings as targets" | a | a _ IdentitySet new: 400. ActiveWorld allMorphsAndBookPagesInto: a. ^ a select: [:e | e isEtoyReadout and: [e target class == self class]]! ! !Player methodsFor: 'slots-user' stamp: 'yo 2/11/2005 16:01'! chooseSlotTypeFor: aGetter "Let the user designate a type for the slot associated with the given getter" | typeChoices typeChosen slotName | slotName _ Utilities inherentSelectorForGetter: aGetter. typeChoices _ Vocabulary typeChoices. typeChosen _ (SelectionMenu labelList: (typeChoices collect: [:t | t translated]) lines: #() selections: typeChoices) startUpWithCaption: ('Choose the TYPE for ' translated, slotName, ' (currently ' translated, (self slotInfoAt: slotName) type translated, ')'). typeChosen isEmptyOrNil ifTrue: [^ self]. (self typeForSlot: slotName) capitalized = typeChosen ifTrue: [^ self]. (self slotInfoAt: slotName) type: typeChosen. self class allInstancesDo: "allSubInstancesDo:" [:anInst | anInst instVarNamed: slotName asString put: (anInst valueOfType: typeChosen from: (anInst instVarNamed: slotName))]. self updateAllViewers. "does siblings too" ! ! !Player methodsFor: 'slots-user' stamp: 'sw 7/18/2002 11:15'! defaultValueOfType: aSymbol "Answer a default value for the given type -- invoked in compiled user scripts when a parameter tile of the wrong type is present" ^ self initialValueForSlotOfType: aSymbol "Not really intended for that purpose but seemingly serves adequately"! ! !Player methodsFor: 'slots-user' stamp: 'yo 2/12/2005 18:58'! fancyWatcherFor: aGetter "Anser a labeled readout for viewing a value textuallyi" | aWatcher aColor aLine itsName aSelector aLabel | aWatcher _ self unlabeledWatcherFor: aGetter. aColor _ Color r: 0.387 g: 0.581 b: 1.0. aLine _ WatcherWrapper newRow. aLine player: self variableName: (aSelector _ Utilities inherentSelectorForGetter: aGetter). itsName _ aWatcher externalName. aWatcher setNameTo: 'readout'. aLine addMorphFront: (self tileReferringToSelf borderWidth: 0; layoutInset: 4@0; typeColor: aColor; color: aColor; bePossessive). aLabel _ StringMorph contents: aSelector translated, ' = ' font: ScriptingSystem fontForTiles. aLabel setProperty: #watcherLabel toValue: true. aLine addMorphBack: aLabel. aLine addMorphBack: aWatcher. aLine setNameTo: itsName. ^ aLine! ! !Player methodsFor: 'slots-user' stamp: 'dgd 2/22/2003 13:43'! hasUserDefinedScripts ^self class scripts notEmpty! ! !Player methodsFor: 'slots-user' stamp: 'sw 9/25/2001 22:28'! initialValueForSlotOfType: aType "Answer the default initial value to ascribe to a slot of the given type" ^ (Vocabulary vocabularyForType: aType) initialValueForASlotFor: self! ! !Player methodsFor: 'slots-user' stamp: 'yo 2/12/2005 20:09'! offerGetterTiles: slotName "For a player-type slot, offer to build convenient compound tiles that otherwise would be hard to get" | typeChoices typeChosen thePlayerThereNow slotChoices slotChosen getterTiles aCategoryViewer playerGetter | typeChoices := Vocabulary typeChoices. typeChosen := (SelectionMenu labelList: (typeChoices collect: [:t | t translated]) lines: #() selections: typeChoices) startUpWithCaption: ('Choose the TYPE of data to get from {1}''s {2}' translated format: {self externalName. slotName translated}). typeChosen isEmptyOrNil ifTrue: [^self]. thePlayerThereNow := self perform: (Utilities getterSelectorFor: slotName). thePlayerThereNow ifNil: [thePlayerThereNow := self presenter standardPlayer]. slotChoices := thePlayerThereNow slotNamesOfType: typeChosen. slotChoices isEmpty ifTrue: [^self inform: 'sorry -- no slots of that type' translated]. slotChoices _ slotChoices asSortedArray. slotChosen := (SelectionMenu labelList: (slotChoices collect: [:t | t translated]) selections: slotChoices) startUpWithCaption: ('Choose the datum you want to extract from {1}''s {2}' translated format: {self externalName. slotName translated}). slotChosen isEmptyOrNil ifTrue: [^self]. "Now we want to tear off tiles of the form holder's valueAtCursor's foo" getterTiles := nil. aCategoryViewer := CategoryViewer new initializeFor: thePlayerThereNow categoryChoice: 'basic'. getterTiles := aCategoryViewer getterTilesFor: (Utilities getterSelectorFor: slotChosen) type: typeChosen. aCategoryViewer := CategoryViewer new initializeFor: self categoryChoice: 'basic'. playerGetter := aCategoryViewer getterTilesFor: (Utilities getterSelectorFor: slotName) type: #Player. getterTiles submorphs first acceptDroppingMorph: playerGetter event: nil. "the pad" "simulate a drop" getterTiles makeAllTilesGreen. getterTiles justGrabbedFromViewer: false. (getterTiles firstSubmorph) changeTableLayout; hResizing: #shrinkWrap; vResizing: #spaceFill. ActiveHand attachMorph: getterTiles! ! !Player methodsFor: 'slots-user' stamp: 'yo 2/11/2005 15:44'! removeSlotNamed: aSlotName "The user has requested that an instance variable be removed..." | aSetter aGetter | (self okayToRemoveSlotNamed: aSlotName) ifFalse: [^ self inform: ('Sorry, {1} is in use in a script.' translated format: {aSlotName})]. aSetter _ Utilities setterSelectorFor: aSlotName. aGetter _ Utilities getterSelectorFor: aSlotName. ((self systemNavigation allCallsOn: aSetter) size > 0 or: [(self systemNavigation allCallsOn: aGetter) size > 0]) ifTrue: [self inform: 'Caution!! There may be scripts belonging to other objects that may rely on the presence of this variable. If there are, they may now be broken. You may need to fix them up manually.' translated]. self class removeInstVarName: aSlotName asString. self updateAllViewers! ! !Player methodsFor: 'slots-user' stamp: 'yo 7/2/2004 19:36'! renameSlot: oldSlotName | reply newSlotName | reply := FillInTheBlank request: 'New name for "' translated , oldSlotName , '":' initialAnswer: oldSlotName. reply isEmpty ifTrue: [^self]. newSlotName := ScriptingSystem acceptableSlotNameFrom: reply forSlotCurrentlyNamed: oldSlotName asSlotNameIn: self world: self costume currentWorld. self renameSlot: oldSlotName newSlotName: newSlotName! ! !Player methodsFor: 'slots-user' stamp: 'sw 3/8/2004 22:14'! renameSlot: oldSlotName newSlotName: newSlotName "Give an existing instance variable a new name" self class renameSilentlyInstVar: oldSlotName to: newSlotName. self renameSlotInWatchersOld: oldSlotName new: newSlotName. self updateAllViewers. self presenter allExtantPlayers do: [:aPlayer | (aPlayer hasScriptReferencing: oldSlotName ofPlayer: self) ifTrue: [aPlayer noteRenameOf: oldSlotName to: newSlotName inPlayer: self]]. self presenter hasAnyTextuallyCodedScripts ifTrue: [self inform: 'Caution!! References in texutally coded scripts won''t be renamed.']. ^ true! ! !Player methodsFor: 'slots-user' stamp: 'sw 7/4/2004 00:26'! setFloatPrecisionFor: aReadout "If appropriate, set the floatPrecision for the given watcher readout (an UpdatingStringMorph), whose getter is assumed already to be established." | precision | (precision _ self defaultFloatPrecisionFor: aReadout getSelector) ~= 1 ifTrue: [aReadout floatPrecision: precision]! ! !Player methodsFor: 'slots-user' stamp: 'yo 8/1/2004 19:46'! setPrecisionFor: slotName "Set the precision for the given slot name" | aList aMenu reply val aGetter places | aGetter := Utilities getterSelectorFor: slotName. places := Utilities decimalPlacesForFloatPrecision: (self defaultFloatPrecisionFor: aGetter). aList := #('0' '1' '2' '3' '4' '5' '6'). aMenu := SelectionMenu labels: aList selections: (aList collect: [:m | m asNumber]). reply := aMenu startUpWithCaption: ('How many decimal places? (currently {1})' translated format: {places}). reply ifNotNil: [(self slotInfo includesKey: slotName) ifTrue: ["it's a user slot" (self slotInfoAt: slotName) floatPrecision: (Utilities floatPrecisionForDecimalPlaces: reply). self class allInstancesDo: [:anInst | reply == 0 ifFalse: [((val := anInst instVarNamed: slotName asString) isInteger) ifTrue: [anInst instVarNamed: slotName asString put: val asFloat]]. anInst updateAllViewers]] ifFalse: ["it's specifying a preference for precision on a system-defined numeric slot" self noteDecimalPlaces: reply forGetter: aGetter. self updateAllViewers]]! ! !Player methodsFor: 'slots-user' stamp: 'gm 2/24/2003 18:06'! slotInfoAt: slotName | info | info := self slotInfo at: slotName ifAbsent: [nil]. info ifNil: [self slotInfo at: slotName put: (info := SlotInformation new initialize)]. (info isKindOf: Symbol) ifTrue: ["bkward compat" self slotInfo at: slotName put: (info := SlotInformation new type: info)]. ^info! ! !Player methodsFor: 'slots-user' stamp: 'sw 7/26/2001 12:01'! slotInfoAt: slotName ifAbsent: aBlock "If the receiver has a slot of the given name, answer its slot info, else answer nil" | info | info _ self slotInfo at: slotName ifAbsent: [^ aBlock value]. ^ info! ! !Player methodsFor: 'slots-user' stamp: 'sw 5/16/2001 13:01'! slotInfoForGetter: aGetter "Answer a SlotInformation object which describes an instance variable of mine retrieved via the given getter, or nil if none" ^ self slotInfo at: (Utilities inherentSelectorForGetter: aGetter) ifAbsent: [nil]! ! !Player methodsFor: 'slots-user' stamp: 'sw 5/16/2001 18:29'! slotNamesOfType: aType "Answer a list of potential slot names of the given type in the receiver" | fullList forViewer gettersToOffer | fullList _ (ScriptingSystem systemSlotNamesOfType: aType), (self class slotGettersOfType: aType). forViewer _ costume renderedMorph selectorsForViewer select: [:aSel | aSel beginsWith: 'get']. gettersToOffer _ fullList select: [:anItem | forViewer includes: anItem]. ^ gettersToOffer collect: [:aSel | Utilities inherentSelectorForGetter: aSel]! ! !Player methodsFor: 'slots-user' stamp: 'sw 1/6/2005 02:02'! tearOffFancyWatcherFor: aGetter "Hand the user a labeled readout for viewing a numeric value" (self fancyWatcherFor: aGetter) openInHand! ! !Player methodsFor: 'slots-user' stamp: 'sw 1/6/2005 18:16'! tearOffUnlabeledWatcherFor: aGetter "Hand the user anUnlabeled readout for viewing a numeric value" | readout aWrapper | readout _ self unlabeledWatcherFor: aGetter. aWrapper _ WatcherWrapper new. aWrapper player: self variableName: (Utilities inherentSelectorForGetter: aGetter). aWrapper addMorphBack: readout. readout setNameTo: 'readout'. "The wrapper bears the name for the user" aWrapper openInHand! ! !Player methodsFor: 'slots-user' stamp: 'sw 8/12/2004 02:27'! tearOffWatcherFor: aSlotGetter "Tear off a simple textual watcher for the slot whose getter is provided" | aWatcher anInterface info isNumeric | info _ self slotInfoForGetter: aSlotGetter. info ifNotNil: [isNumeric _ info type == #Number] ifNil: [anInterface _ Vocabulary eToyVocabulary methodInterfaceAt: aSlotGetter ifAbsent: [nil]. isNumeric _ anInterface notNil and: [anInterface resultType == #Number]]. aWatcher _ UpdatingStringMorph new. aWatcher growable: true; getSelector: aSlotGetter; putSelector: (info notNil ifTrue: [ScriptingSystem setterSelectorForGetter: aSlotGetter] ifFalse: [anInterface companionSetterSelector]); setNameTo: (info notNil ifTrue: [Utilities inherentSelectorForGetter: aSlotGetter] ifFalse: [anInterface wording]); target: self. isNumeric ifFalse: [aWatcher useStringFormat] ifTrue: [self setFloatPrecisionFor: aWatcher]. aWatcher step; fitContents; openInHand! ! !Player methodsFor: 'slots-user' stamp: 'sw 1/5/2005 22:17'! unlabeledWatcherFor: aGetter "Answer an unnlabeled readout for viewing a numeric-valued slot of mine" | aWatcher info anInterface watcherWording itsType vocab aSetter | info _ self slotInfoForGetter: aGetter. info ifNotNil: [itsType _ info type. watcherWording _ Utilities inherentSelectorForGetter: aGetter. aSetter _ Utilities setterSelectorFor: watcherWording] ifNil: [anInterface _Vocabulary eToyVocabulary methodInterfaceAt: aGetter ifAbsent: [nil]. anInterface ifNotNil: [itsType _ anInterface resultType. aSetter _ anInterface companionSetterSelector] ifNil: [itsType _ #Unknown. aSetter _ nil]. watcherWording _ anInterface ifNotNil: [anInterface wording] ifNil: ['*']]. vocab _ Vocabulary vocabularyForType: itsType. aWatcher _ vocab updatingTileForTarget: self partName: watcherWording getter: aGetter setter: aSetter. aWatcher setNameTo: (self externalName, '''s ', watcherWording). aWatcher minHeight: (vocab wantsArrowsOnTiles ifTrue: [22] ifFalse: [14]). ^ aWatcher! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'! getFogColor ^self costume renderedMorph fogColor! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:22'! getFogDensity ^self costume renderedMorph fogDensity * 100! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'! getFogRangeEnd ^self costume renderedMorph fogRangeEnd * 100! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'! getFogRangeStart ^self costume renderedMorph fogRangeStart * 100! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'! getFogType ^self costume renderedMorph fogType! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:11'! setFogColor: x self costume renderedMorph fogColor: x! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'! setFogDensity: x self costume renderedMorph fogDensity: x * 0.01! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'! setFogRangeEnd: x self costume renderedMorph fogRangeEnd: x * 0.01! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:23'! setFogRangeStart: x self costume renderedMorph fogRangeStart: x * 0.01! ! !Player methodsFor: 'slots-wonderland' stamp: 'ar 5/15/2001 14:12'! setFogType: x self costume renderedMorph fogType: x! ! !Player methodsFor: 'testing' stamp: 'sw 9/27/2001 17:26'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Player! ! !Player methodsFor: 'viewer' stamp: 'sw 5/22/2001 14:56'! elementTypeFor: aStringOrSymbol vocabulary: aVocabulary "Answer whether aStringOrSymbol is best characterized as a #systemSlot, #systemScript, #userSlot, or #userScript. This is ancient and odious but too tedious to rip out at this point." | aSymbol anInterface aSlotName | aSymbol _ aStringOrSymbol asSymbol. aSlotName _ Utilities inherentSelectorForGetter: aSymbol. (self slotInfo includesKey: aSlotName) ifTrue: [^ #userSlot]. (self class isUniClass and: [self class scripts includesKey: aSymbol]) ifTrue: [^ #userScript]. anInterface _ aVocabulary methodInterfaceAt: aSymbol ifAbsent: [nil]. ^ anInterface ifNotNil: [(anInterface resultType == #unknown) ifTrue: [#systemScript] ifFalse: [#systemSlot]] ifNil: [#systemScript]! ! !Player methodsFor: 'viewer' stamp: 'sw 5/2/2001 23:46'! graphicForViewerTab "Answer the graphic to show in the tab of a Viewer looking at me" ^ self costume renderedMorph! ! !Player methodsFor: 'viewer' stamp: 'dgd 2/22/2003 13:43'! hasUserDefinedSlots ^self class slotInfo notEmpty! ! !Player methodsFor: 'viewer' stamp: 'yo 2/11/2005 15:48'! infoFor: anElement inViewer: aViewer "The user made a gesture asking for info/menu relating" | aMenu elementType aSelector | elementType := self elementTypeFor: anElement vocabulary: aViewer currentVocabulary. elementType = #systemSlot | (elementType == #userSlot) ifTrue: [^self slotInfoButtonHitFor: anElement inViewer: aViewer]. aMenu := MenuMorph new defaultTarget: self. aMenu defaultTarget: self. aSelector := anElement asSymbol. elementType == #userScript ifTrue: [aMenu add: 'destroy "' translated , anElement , '"' selector: #removeScriptWithSelector: argument: aSelector. aMenu add: 'rename "' translated, anElement , '"' selector: #renameScript: argument: aSelector. aMenu add: 'textual scripting pane' translated selector: #makeIsolatedCodePaneForSelector: argument: aSelector. aSelector numArgs > 0 ifTrue: [aMenu add: 'remove parameter' translated selector: #ceaseHavingAParameterFor: argument: aSelector] ifFalse: [aMenu add: 'add parameter' translated selector: #startHavingParameterFor: argument: aSelector. aMenu add: 'button to fire this script' translated selector: #tearOffButtonToFireScriptForSelector: argument: aSelector]. aMenu add: 'edit balloon help' translated selector: #editDescriptionForSelector: argument: aSelector]. aMenu add: 'show categories....' translated target: aViewer selector: #showCategoriesFor: argument: aSelector. aMenu items isEmpty ifTrue: ["Never 0 at the moment because of show categories addition" aMenu add: 'ok' translated action: nil]. aMenu addTitle: anElement asString , ' (' , elementType translated , ')'. aMenu popUpInWorld: aViewer world! ! !Player methodsFor: 'viewer' stamp: 'sw 9/27/2001 17:41'! initialTypeForSlotNamed: aName "Answer the initial type to be ascribed to the given instance variable" ^ #Number! ! !Player methodsFor: 'viewer' stamp: 'ar 5/26/2001 16:14'! isPlayerLike "Return true if the receiver is a player-like object" ^true! ! !Player methodsFor: 'viewer' stamp: 'tk 8/3/2001 11:08'! newScriptorAround: aPhrase "Sprout a scriptor around aPhrase, thus making a new script. aPhrase may either be a PhraseTileMorph (classic tiles 1997-2001) or a SyntaxMorph (2001 onward)" | aScriptEditor aUniclassScript tw blk | aUniclassScript _ self class permanentUserScriptFor: self unusedScriptName player: self. aScriptEditor _ aUniclassScript instantiatedScriptEditorForPlayer: self. Preferences universalTiles ifTrue: [ aScriptEditor install. "aScriptEditor hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellPositioning: #topLeft; setProperty: #autoFitContents toValue: true." aScriptEditor insertUniversalTiles. "Gets an empty SyntaxMorph for a MethodNode" tw _ aScriptEditor findA: TwoWayScrollPane. aPhrase ifNotNil: [blk _ (tw scroller findA: SyntaxMorph "MethodNode") findA: BlockNode. blk addMorphFront: aPhrase. aPhrase accept. ]. SyntaxMorph setSize: nil andMakeResizable: aScriptEditor. ] ifFalse: [ aPhrase ifNotNil: [aScriptEditor phrase: aPhrase] "does an install" ifNil: [aScriptEditor install] ]. self class allSubInstancesDo: [:anInst | anInst scriptInstantiationForSelector: aUniclassScript selector]. "The above assures the presence of a ScriptInstantiation for the new selector in all siblings" self updateAllViewersAndForceToShow: #scripts. ^ aScriptEditor! ! !Player methodsFor: 'viewer' stamp: 'sw 5/4/2001 05:19'! tileToRefer "Answer a reference tile that comprises an alias to me. Forgive this temporary and seemingly gratuituous revectoring as worlds collide" ^ self tileReferringToSelf! ! !Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 17:09'! getCurrentFrameForm ^ self sendMessageToCostume: #getCurrentFrameForm ! ! !Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:41'! getFrameGraphic "Answer a form representing the receiver's costume's current graphic" ^ self sendMessageToCostume: #getCurrentFrameForm ! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:03'! getIsRunning ^ self sendMessageToCostume: #getIsRunning! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:06'! getRepeat ^ self sendMessageToCostume: #getRepeat! ! !Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:38'! getTotalFrames "Answer the receiver's costume's totalFrames. Applies to MPEGMoviePlayerMorphs" ^ self sendMessageToCostume: #totalFrames ! ! !Player methodsFor: 'playing commands' stamp: 'sw 10/13/2004 06:37'! getTotalSeconds "Answer the total number of seconds in the receiver's costume, typically a movie" ^ self sendMessageToCostume: #totalSeconds ! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:29'! play self sendMessageToCostume: #play! ! !Player methodsFor: 'playing commands' stamp: 'jm 10/12/2004 11:17'! playUntilPosition: aNumber self sendMessageToCostume: #playUntilPosition: with: aNumber! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:32'! rewind self sendMessageToCostume: #rewind! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 22:07'! setRepeat: aBoolean self sendMessageToCostume: #setRepeat: with: aBoolean! ! !Player methodsFor: 'playing commands' stamp: 'dgd 2/15/2004 21:31'! stop self sendMessageToCostume: #stop! ! !Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 16:30'! totalFrames ^ self sendMessageToCostume: #totalFrames ! ! !Player methodsFor: 'playing commands' stamp: 'jm 9/28/2004 16:30'! totalSeconds ^ self sendMessageToCostume: #totalSeconds ! ! !Player methodsFor: 'translation' stamp: 'yo 1/18/2004 10:59'! labelFromWatcher: w "Answer the morph holding the label of the given watcher" ^ w owner owner submorphs third submorphs second! ! !Player methodsFor: 'translation' stamp: 'sw 1/6/2005 16:34'! renameSlotInWatchersOld: oldName new: newName "A variable has been renamed; get all relevant extant watchers updated. All this assumed to be happening in the ActiveWorld" | wasStepping oldGetter | oldGetter _ Utilities getterSelectorFor: oldName. self allPossibleWatchersFromWorld do: [:aWatcher | (aWatcher getSelector = oldGetter) ifTrue: [(wasStepping _ aWatcher isStepping) ifTrue: [aWatcher stopStepping]. aWatcher getSelector: (Utilities getterSelectorFor: newName). aWatcher putSelector ifNotNil: [aWatcher putSelector: (Utilities setterSelectorFor: newName)]. ((aWatcher isKindOf: UpdatingStringMorph) and: [aWatcher hasStructureOfComplexWatcher]) ifTrue: "Old style fancy watcher" [aWatcher owner owner traverseRowTranslateSlotOld: oldName to: newName. (aWatcher target labelFromWatcher: aWatcher) contents: newName, ' = ']. (aWatcher ownerThatIsA: WatcherWrapper) ifNotNilDo: [:wrapper | wrapper player: self variableName: newName]. wasStepping ifTrue: [aWatcher startStepping]]]! ! !Player methodsFor: '*customevents-custom events' stamp: 'nk 11/1/2004 11:26'! getTriggeringObject "Answer the Player that is triggering the current script, or the default UnscriptedPlayer if none." | rcvr | rcvr := GetTriggeringObjectNotification signal. ^rcvr ifNil: [ self costume presenter standardPlayer ] ifNotNil: [ rcvr isMorph ifTrue: [ rcvr assuredPlayer ] ifFalse: [ rcvr ]]! ! !Player methodsFor: '*customevents-custom events' stamp: 'nk 8/26/2003 10:50'! triggerCustomEvent: aSymbol "Trigger whatever scripts may be connected to the custom event named aSymbol" self costume renderedMorph triggerCustomEvent: aSymbol! ! !Player methodsFor: '*customevents-custom events' stamp: 'nk 11/1/2004 10:48'! triggerScript: aSymbol "Perform the script of the given name, which is guaranteed to exist. However, it's possible that the script may still result in a DNU, which will be swallowed and reported to the Transcript." ^ [[self perform: aSymbol] on: GetTriggeringObjectNotification do: [ :ex | ex isNested ifTrue: [ ex pass ] ifFalse: [ ex resume: self ]]] on: MessageNotUnderstood do: [:ex | ScriptingSystem reportToUser: (String streamContents: [:s | s nextPutAll: self externalName; nextPutAll: ': exception in script '; print: aSymbol; nextPutAll: ' : '; print: ex]). ex return: self "ex pass"]! ! !Player methodsFor: '*customevents-scripts-kernel' stamp: 'nk 9/25/2003 11:53'! existingScriptInstantiationForSelector: scriptName "Answer the existing script instantiation for the given selector, or nil if none" scriptName ifNil: [^ nil]. Symbol hasInterned: scriptName ifTrue: [ :sym | self costume actorStateOrNil ifNotNilDo: [ :actorState | ^actorState instantiatedUserScriptsDictionary at: sym ifAbsent: [nil]]]. ^ nil! ! !Player methodsFor: '*customevents-scripts-kernel' stamp: 'nk 9/24/2003 17:36'! instantiatedUserScriptsDo: aBlock "Evaluate aBlock on behalf of all the instantiated user scripts in the receiver" | aState aCostume | ((aCostume _ self costume) notNil and: [(aState _ aCostume actorStateOrNil) notNil]) ifTrue: [aState instantiatedUserScriptsDictionary do: aBlock]! ! !Player methodsFor: '*customevents-scripts-kernel' stamp: 'nk 8/18/2004 17:40'! pacifyScript: aSymbol "Make sure the script represented by the symbol doesn't do damage by lingering in related structures on the morph side" | aHandler aUserScript | aUserScript _ self class userScriptForPlayer: self selector: aSymbol. aUserScript ifNil: [self flag: #deferred. ^ Beeper beep]. "Maddeningly, without this line here the thing IS nil and the debugger is in a bad state (the above note dates from 1/12/99 ?!!" self class allInstancesDo: [:aPlayer | | itsCostume | aPlayer actorState instantiatedUserScriptsDictionary removeKey: aSymbol ifAbsent: []. itsCostume _ aPlayer costume renderedMorph. (aHandler _ itsCostume eventHandler) ifNotNil: [aHandler forgetDispatchesTo: aSymbol]. itsCostume removeEventTrigger: aSymbol ]! ! !Player methodsFor: '*customevents-scripts-kernel' stamp: 'nk 9/25/2003 11:38'! renameScript: oldSelector newSelector: newSelector "Rename the given script to have the new selector" | aUserScript anInstantiation aDict | oldSelector = newSelector ifTrue: [^ self]. oldSelector numArgs == 0 ifTrue: [self class allSubInstancesDo: [:aPlayer | | itsCostume | anInstantiation _ aPlayer scriptInstantiationForSelector: oldSelector. newSelector numArgs == 0 ifTrue: [anInstantiation changeSelectorTo: newSelector]. aDict _ aPlayer costume actorState instantiatedUserScriptsDictionary. itsCostume _ aPlayer costume renderedMorph. itsCostume renameScriptActionsFor: aPlayer from: oldSelector to: newSelector. self currentWorld renameScriptActionsFor: aPlayer from: oldSelector to: newSelector. aDict removeKey: oldSelector. newSelector numArgs == 0 ifTrue: [aDict at: newSelector put: anInstantiation. anInstantiation assureEventHandlerRepresentsStatus]]] ifFalse: [newSelector numArgs == 0 ifTrue: [self class allSubInstancesDo: [:aPlayer | anInstantiation _ aPlayer scriptInstantiationForSelector: newSelector. anInstantiation assureEventHandlerRepresentsStatus]]]. aUserScript _ self class userScriptForPlayer: self selector: oldSelector. aUserScript renameScript: newSelector fromPlayer: self. "updates all script editors, and inserts the new script in my scripts directory" self class removeScriptNamed: oldSelector. ((self existingScriptInstantiationForSelector: newSelector) notNil and: [newSelector numArgs > 0]) ifTrue: [self error: 'ouch']. self updateAllViewersAndForceToShow: 'scripts'! ! !Player methodsFor: '*customevents-scripts-kernel' stamp: 'nk 11/1/2004 11:14'! runScript: aSelector "Called from script-activation buttons. Provides a safe way to run a script that may have changed its name" (self respondsTo: aSelector) ifTrue: [^ self triggerScript: aSelector]. self inform: 'Oops, object "', self externalName, '" no longer has a script named "', aSelector, '". It must have been deleted or renamed.'! ! !Player methodsFor: '*customevents-misc' stamp: 'nk 9/24/2003 17:32'! actorState "Answer the receiver's actorState, creating one if necessary." ^ self costume actorState! ! !Player methodsFor: '*customevents-misc' stamp: 'nk 9/24/2003 18:26'! noteDeletionOf: aMorph fromWorld: aWorld "aMorph, while pointing to me as its costumee, has been deleted" "This may be too aggressive because deletion of a morph may not really mean deletion of its associated player -- in light of hoped-for multiple viewing" | viewers scriptors viewerFlaps | viewers _ OrderedCollection new. viewerFlaps _ OrderedCollection new. scriptors _ OrderedCollection new. aWorld allMorphs do: [:m | m isAViewer ifTrue: [viewers add: m]. ((m isKindOf: ViewerFlapTab) and: [m scriptedPlayer == self]) ifTrue: [viewerFlaps add: m]. ((m isKindOf: ScriptEditorMorph) and: [m myMorph == aMorph]) ifTrue: [scriptors add: m]]. aMorph removeAllEventTriggersFor: self. aWorld removeAllEventTriggersFor: self. viewers do: [:v | v noteDeletionOf: aMorph]. viewerFlaps do: [:v | v dismissViaHalo]. scriptors do: [:s | s privateDelete] ! ! !Player methodsFor: '*customevents-costume' stamp: 'nk 9/24/2003 17:33'! costume: aMorph "Make aMorph be the receiver's current costume" | itsBounds | costume == aMorph ifTrue: [^ self]. costume ifNotNil: [self rememberCostume: costume renderedMorph. itsBounds _ costume bounds. (costume ownerThatIsA: HandMorph orA: PasteUpMorph) replaceSubmorph: costume topRendererOrSelf by: aMorph. aMorph position: itsBounds origin. aMorph actorState: costume actorStateOrNil. aMorph setNameTo: costume externalName]. aMorph player: self. costume _ aMorph. aMorph arrangeToStartStepping! ! !Player methodsFor: '*flexibleVocabularies-costume' stamp: 'nk 9/4/2004 11:48'! hasAnyBorderedCostumes "Answer true if any costumes of the receiver are BorderedMorph descendents" self costumesDo: [:cost | (cost understandsBorderVocabulary) ifTrue: [^ true]]. ^ false! ! !Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 6/4/2004 13:59'! addDocumentationForScriptsTo: aStream "Add documentation for every script in the receiver to the stream" self scripts do: [:aScript | aScript selector ifNotNil: [aStream cr; cr. aStream nextPutAll: self typicalInstanceName, '.'. self printMethodChunk: aScript selector withPreamble: false on: aStream moveSource: false toFile: nil. aStream position: (aStream position - 2)]]. self scripts size == 0 ifTrue: [aStream cr; tab; nextPutAll: 'has no scripts']! ! !Player class methodsFor: 'user-scripted subclasses' stamp: 'sw 6/4/2004 15:04'! addMethodReferencesTo: aCollection "For each extant script in the receiver, add a MethodReference object" | sel | self scripts do: [:aScript | (sel _ aScript selector) ifNotNil: [aCollection add: (MethodReference new setStandardClass: self methodSymbol: sel)]]! ! !Player class methodsFor: 'slots' stamp: 'NS 1/28/2004 14:41'! compileInstVarAccessorsFor: varName "Compile getters and setteres for the given instance variable name" | nameString | nameString _ varName asString capitalized. self compileSilently: ('get', nameString, ' ^ ', varName) classified: 'access'. self compileSilently: ('set', nameString, ': val ', varName, ' _ val') classified: 'access'! ! !Player class methodsFor: 'slots' stamp: 'sw 5/25/2001 10:26'! slotGettersOfType: aType "Answer a list of gettter selectors for slots of mine of the given type" | aList | aList _ OrderedCollection new. self slotInfo associationsDo: [:assoc | (assoc value type = aType) ifTrue: [aList add: (Utilities getterSelectorFor: assoc key)]]. ^ aList! ! !Player class methodsFor: 'other' stamp: 'sw 7/27/2001 13:45'! abandonOldReferenceScheme "Abandon the old reference scheme" "(ActiveWorld presenter allExtantPlayers collect: [:aPlayer | aPlayer class]) asSet do: [:aPlayerClass | aPlayerClass abandonOldReferenceScheme]" self isUniClass ifTrue: [self userScriptsDo: [:aScript | aScript recompileScriptFromTilesUnlessTextuallyCoded]. self class selectors do: [:sel | self class removeSelector: sel]. self class instVarNames do: [:aName | self class removeInstVarName: aName]. self organization removeEmptyCategories. self class organization removeEmptyCategories]! ! !Player class methodsFor: 'other' stamp: 'sw 1/6/2001 06:27'! nameForViewer "Answer the name by which the receiver is to be referred in a viewer" ^ self isUniClass ifTrue: [self someInstance getName] ifFalse: [super nameForViewer]! ! !Player class methodsFor: 'other' stamp: 'sw 6/4/2004 13:56'! typicalInstanceName "For the purpose of documentation, answer the name of a named instance of the receiver, if possible, else answer the class name" | known | known _ (self allInstances collect: [:i | i knownName]) detect: [:n | n isEmptyOrNil not] ifNone: [nil]. ^ known ifNil: [self name]! ! !Player class methodsFor: 'other' stamp: 'tk 9/28/2001 11:43'! wantsChangeSetLogging "Log changes for Player itself, but not for automatically-created subclasses like Player1, Player2, but *do* log it for uniclasses that have been manually renamed." ^ (self == Player or: [(self name beginsWith: 'Player') not]) or: [Preferences universalTiles]! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 03:44'! assuredMethodInterfaceFor: aSelector "Answer the method interface object for aSelector, creating it if it does not already exist." | selSym aMethodInterface | selSym _ aSelector asSymbol. aMethodInterface _ self scripts at: selSym ifAbsent: [scripts at: selSym put: (self nascentUserScriptInstance playerClass: self selector: selSym)]. ^ aMethodInterface! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 02:50'! atSelector: aSelector putScript: aMethodWithInterface "Place the given method interface in my directory of scripts, at the given selector" self scripts at: aSelector asSymbol put: aMethodWithInterface! ! !Player class methodsFor: 'scripts' stamp: 'sw 10/17/2001 09:08'! bringScriptsUpToDate "Bring all the receiver's scripts up to date, after, for example, a name change" self scripts do: [:aUniclassScript | aUniclassScript bringUpToDate]! ! !Player class methodsFor: 'scripts' stamp: 'sw 12/19/2003 23:28'! namedUnaryTileScriptSelectors "Answer a list of all the selectors of named unary tile scripts" | sel | scripts ifNil: [^ OrderedCollection new]. ^ scripts select: [:aScript | ((sel _ aScript selector) ~~ nil) and: [sel numArgs == 0]] thenCollect: [:aScript | aScript selector]! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/18/2001 18:42'! nascentUserScriptInstance "Answer a new script object of the appropriate class" | classToUse | classToUse _ Preferences universalTiles ifTrue: [MethodWithInterface] ifFalse: [UniclassScript]. ^ classToUse new! ! !Player class methodsFor: 'scripts' stamp: 'sw 2/17/2001 00:59'! permanentUserScriptFor: aSelector player: aPlayer "Create and answer a suitable script object for the given player (who will be an instance of the receiver) and selector. Save that script-interface object in my (i.e. the class's) directory of scripts" | entry | scripts ifNil: [scripts _ IdentityDictionary new]. entry _ self nascentUserScriptInstance playerClass: aPlayer class selector: aSelector. scripts at: aSelector put: entry. ^ entry! ! !Player class methodsFor: 'scripts' stamp: 'NS 1/30/2004 13:11'! removeScriptNamed: aScriptName aScriptName ifNotNil: [scripts removeKey: aScriptName. self removeSelectorSilently: aScriptName]! ! !Player class methodsFor: 'scripts' stamp: 'sw 4/20/2001 20:11'! scripts "Answer the receiver's scripts -- an IdentityDictionary" scripts ifNil: [scripts _ IdentityDictionary new] ifNotNil: [self cleanseScriptsOfNilKeys]. ^ scripts! ! !Player class methodsFor: 'scripts' stamp: 'sw 3/28/2001 16:18'! userScriptForPlayer: aPlayer selector: aSelector "Answer the user script for the player (one copy for all instances of the uniclass) and selector" | newEntry existingEntry | scripts ifNil: [scripts _ IdentityDictionary new]. existingEntry _ scripts at: aSelector ifAbsent: [nil]. "Sorry for all the distasteful isKindOf: and isMemberOf: stuff here, folks; it arises out of concern for preexisting content saved on disk from earlier stages of this architecture. Someday much of it could be cut loose" Preferences universalTiles ifTrue: [(existingEntry isMemberOf: MethodWithInterface) ifTrue: [^ existingEntry]. newEntry _ (existingEntry isKindOf: UniclassScript) ifTrue: [existingEntry as: MethodWithInterface] "let go of extra stuff if it was UniclassScript" ifFalse: [MethodWithInterface new playerClass: aPlayer class selector: aSelector]. scripts at: aSelector put: newEntry. ^ newEntry] ifFalse: [(existingEntry isKindOf: UniclassScript) ifTrue: [^ existingEntry] ifFalse: [newEntry _ UniclassScript new playerClass: self selector: aSelector. scripts at: aSelector put: newEntry. existingEntry ifNotNil: "means it is a grandfathered UserScript that needs conversion" [newEntry convertFromUserScript: existingEntry]. ^ newEntry]]! ! !Player class methodsFor: 'namespace' stamp: 'NS 1/28/2004 14:41'! compileReferenceAccessorFor: varName "Compile reference accessors for the given variable. If the #capitalizedReferences preference is true, then nothing is done here" Preferences capitalizedReferences ifTrue: [^ self]. self class compileSilently: ((self referenceAccessorSelectorFor: varName), ' ^ ', varName) classified: 'reference'! ! !Player class methodsFor: 'housekeeping' stamp: 'sw 12/15/2004 20:43'! cleanseScripts "Fix up various known structure errors in the uniclass relating to the scripts dctionary. Answer the number of fixes made." | errs ed | scripts ifNil: [scripts _ IdentityDictionary new]. errs _ 0. (scripts includesKey: nil) ifTrue: [errs _ errs + 1. scripts removeKey: nil]. scripts keysAndValuesDo: [:sel :uniclassScript | uniclassScript ifNil: [errs _ errs + 1. Transcript cr; show: ' fix type 1, nil scripts key'. scripts removeKey: sel] ifNotNil: [(ed _ uniclassScript currentScriptEditor) ifNil: [errs _ errs + 1. Transcript cr; show: ' fix type 2, sel = ', sel. self someInstance removeScriptWithSelector: uniclassScript selector.] ifNotNil: [uniclassScript playerClassPerSe ifNil: [errs _ errs + 1. Transcript cr; show: ' fix type 3, sel = ', sel. uniclassScript playerClass: self selector: sel] ifNotNil: [(ed scriptName ~= uniclassScript selector) ifTrue: [errs _ errs + 1. ed restoreScriptName: sel. Transcript cr; show: ' fix type 4, sel = ', sel.]]]]]. ^ errs! ! !Player class methodsFor: 'housekeeping' stamp: 'sw 4/10/2001 20:03'! cleanseScriptsOfNilKeys "If, owing to an earlier bug, the receiver's scripts dictionary has a nil key, remove that offender before he causes more trouble" scripts ifNotNil: [scripts removeKey: nil ifAbsent: []]! ! !Player class methodsFor: 'housekeeping' stamp: 'sw 12/18/2000 15:45'! isUniClass "UnscriptedPlayer reimplements to false" ^ self ~~ Player! ! !PlayerReferenceReadout methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:58'! mouseDown: evt "Allow the user to respecify this by direct clicking" | aMorph | (putSelector == #unused or: [putSelector isNil]) ifTrue: [^self]. Sensor waitNoButton. aMorph := self world chooseClickTarget. aMorph ifNil: [^self]. objectToView perform: putSelector with: aMorph assuredPlayer. self changed! ! !PlayerReferenceReadout methodsFor: 'initialization' stamp: 'sw 1/6/2005 17:12'! putSelector "Answer the putSelector" ^ putSelector! ! !PlayerReferenceReadout methodsFor: 'initialization' stamp: 'sw 1/6/2005 17:13'! putSelector: aSel "Reset the putSelector" self objectToView: objectToView viewSelector: viewSelector putSelector: aSel! ! !PlayerReferenceReadout methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:24'! isEtoyReadout "Answer whether the receiver can serve as an etoy readout" ^ true! ! !PlayerReferenceReadout methodsFor: 'accessing' stamp: 'sw 1/6/2005 01:38'! target "Answer the object on which I act" ^ objectToView! ! !PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/19/2004 12:48'! playerRepresented "Answer the value of playerRepresented" ^ playerRepresented! ! !PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/28/2004 21:16'! playerRepresented: anObject "Set the value of playerRepresented" playerRepresented _ anObject. self rebuildRow. self setNameTo: anObject costume topRendererOrSelf externalName! ! !PlayerSurrogate methodsFor: 'accessing' stamp: 'sw 7/28/2004 22:19'! rebuildRow "Rebuild the row" | aThumbnail aTileButton aViewerButton | self removeAllMorphs. self layoutInset: 2; cellInset: 3. self beTransparent. aThumbnail _ ThumbnailForAllPlayersTool new objectToView: playerRepresented viewSelector: #graphicForViewerTab. aThumbnail setBalloonText: 'Click here to reveal this object' translated. self addMorphBack: aThumbnail. aThumbnail on: #mouseUp send: #beRevealedInActiveWorld to: playerRepresented. "aMenuButton _ IconicButton new labelGraphic: Cursor menu. aMenuButton target: self; actionSelector: #playerButtonHit; color: Color transparent; borderWidth: 0; shedSelvedge; actWhen: #buttonDown. aMenuButton setBalloonText: 'Press here to get a menu'. self addMorphBack: aMenuButton." aViewerButton _ IconicButton new labelGraphic: (ScriptingSystem formAtKey: #Viewer). aViewerButton color: Color transparent; actWhen: #buttonUp; actionSelector: #beViewed; target: playerRepresented; setBalloonText: 'click here to obtain this object''s Viewer' translated; color: Color transparent; borderWidth: 0; shedSelvedge. self addMorphBack: aViewerButton. aTileButton _ IconicButton new borderWidth: 0. aTileButton labelGraphic: (TileMorph new setToReferTo: playerRepresented) imageForm. aTileButton color: Color transparent; actWhen: #buttonDown; actionSelector: #tearOffTileForSelf; target: playerRepresented; setBalloonText: 'click here to obtain a tile that refers to this player.' translated. self addMorphBack: aTileButton. " aNameMorph _ UpdatingStringMorph new useStringFormat; target: playerRepresented; getSelector: #nameForViewer; setNameTo: 'name'; font: ScriptingSystem fontForNameEditingInScriptor. aNameMorph putSelector: #setName:. aNameMorph setProperty: #okToTextEdit toValue: true. aNameMorph step. self addMorphBack: aNameMorph. aNameMorph setBalloonText: 'Click here to edit the player''s name.'. " ! ! !PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 21:18'! addCustomMenuItems: aMenu hand: aHand "Add cu stom items to the menu" aMenu addList: #( ('grab this object' grabThisObject 'wherever it may be rip this object out of its container and hand it to me.') ('reveal this object' revealThisObject 'make this object visible and put up its halo') ('hand me a tile' handMeATile 'hand me a tile for this object') ('open viewer' viewerForThisObject 'open this object''s Viewer'))! ! !PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:54'! grabThisObject "Hand the user the object represented by the receiver. Invoked from menu, formerly at least." playerRepresented grabPlayerInActiveWorld! ! !PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:52'! handMeATile "Hand the user a tile representing the player for which the receiver is a surrogate" playerRepresented tearOffTileForSelf! ! !PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 18:05'! revealThisObject "Reveal the object I represent" playerRepresented revealPlayerIn: ActiveWorld! ! !PlayerSurrogate methodsFor: 'menu' stamp: 'sw 7/28/2004 20:53'! viewerForThisObject "Open a viewer for the object represented by the receiver" playerRepresented beViewed! ! !PlayerSurrogate methodsFor: 'updating' stamp: 'sw 7/28/2004 20:55'! bringUpToDate "To react to changes in the corrreponding player, rebuild the display with fresh information from its surrogate" self rebuildRow! ! !PlayerSurrogate methodsFor: 'updating' stamp: 'sw 7/28/2004 20:54'! isTileScriptingElement "Answer (for the purpose of updating) whether the receiver is a tile-scripting element" ^ true! ! !PlayerSurrogate commentStamp: '<historical>' prior: 0! An morph representing an E-Toy "Player" in an AllPlayersTool.! !PlayerType methodsFor: 'tiles' stamp: 'dgd 9/6/2003 20:30'! addExtraItemsToMenu: aMenu forSlotSymbol: slotSym "If the receiver has extra menu items to add to the slot menu, here is its chance to do it" aMenu add: 'tiles to get...' translated selector: #offerGetterTiles: argument: slotSym! ! !PlayerType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:30'! defaultArgumentTile "Answer a tile to represent the type" ^ ActiveWorld presenter standardPlayer tileToRefer! ! !PlayerType methodsFor: 'tiles' stamp: 'sw 9/25/2001 21:04'! updatingTileForTarget: aTarget partName: partName getter: getter setter: setter "Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter" ^ PlayerReferenceReadout new objectToView: aTarget viewSelector: getter putSelector: setter! ! !PlayerType methodsFor: 'tiles' stamp: 'sw 9/27/2001 17:33'! wantsArrowsOnTiles "Answer whether this data type wants up/down arrows on tiles representing its values" ^ false! ! !PlayerType methodsFor: 'initial value' stamp: 'sw 9/27/2001 17:29'! initialValueForASlotFor: aPlayer "Answer the value to give initially to a newly created slot of the given type in the given player" ^ aPlayer costume presenter standardPlayer! ! !PlayerType methodsFor: 'initialization' stamp: 'sw 9/27/2001 17:24'! initialize "Initialize the receiver (automatically called when instances are created via 'new')" super initialize. self vocabularyName: #Player! ! !PlayerType methodsFor: 'color' stamp: 'sw 9/27/2001 17:21'! typeColor "Answer the color for tiles to be associated with objects of this type" ^ self subduedColorFromTriplet: #(1.0 0 0.065)! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 7/30/2001 15:55'! label: aStringOrTextOrMorph font: aFont "Label this button with the given string or morph." | r | self removeAllMorphs. "nest label in a row for centering" r _ AlignmentMorph newRow borderWidth: 0; layoutInset: 0; color: Color transparent; hResizing: #shrinkWrap; vResizing: #spaceFill; wrapCentering: #center; cellPositioning: #leftCenter. aStringOrTextOrMorph isMorph ifTrue: [ label _ aStringOrTextOrMorph. r addMorph: aStringOrTextOrMorph] ifFalse: [ label _ aStringOrTextOrMorph asString. r addMorph: (StringMorph contents: label font: aFont)]. self addMorph: r. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 2/17/2002 05:29'! performAction "Inform the model that this button has been pressed. Sent by the controller when this button is pressed. If the button's actionSelector takes any arguments, they are obtained dynamically by sending the argumentSelector to the argumentsProvider" askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]]. actionSelector ifNotNil: [actionSelector numArgs == 0 ifTrue: [model perform: actionSelector] ifFalse: [argumentsProvider ifNotNil: [arguments _ argumentsProvider perform: argumentsSelector]. model perform: actionSelector withArguments: arguments]]! ! !PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 01:03'! arguments: args "If the receiver takes argument(s) that are static, they can be filled by calling this. If its argument(s) are to be dynamically determined, then use an argumentProvider and argumentSelector instead" arguments _ args! ! !PluggableButtonMorph methodsFor: 'arguments' stamp: 'sw 2/17/2002 05:29'! argumentsProvider: anObject argumentsSelector: aSelector "Set the argument provider and selector" argumentsProvider _ anObject. argumentsSelector _ aSelector! ! !PluggableButtonMorph methodsFor: 'copying' stamp: 'sw 2/17/2002 05:29'! veryDeepInner: deepCopier "Copy all of my instance variables. Some need to be not copied at all, but shared. Warning!!!! Every instance variable defined in this class must be handled. We must also implement veryDeepFixupWith:. See DeepCopier class comment." super veryDeepInner: deepCopier. "model _ model. Weakly copied" label _ label veryDeepCopyWith: deepCopier. "getStateSelector _ getStateSelector. a Symbol" "actionSelector _ actionSelector. a Symbol" "getLabelSelector _ getLabelSelector. a Symbol" "getMenuSelector _ getMenuSelector. a Symbol" shortcutCharacter _ shortcutCharacter veryDeepCopyWith: deepCopier. askBeforeChanging _ askBeforeChanging veryDeepCopyWith: deepCopier. triggerOnMouseDown _ triggerOnMouseDown veryDeepCopyWith: deepCopier. offColor _ offColor veryDeepCopyWith: deepCopier. onColor _ onColor veryDeepCopyWith: deepCopier. feedbackColor _ feedbackColor veryDeepCopyWith: deepCopier. showSelectionFeedback _ showSelectionFeedback veryDeepCopyWith: deepCopier. allButtons _ nil. "a cache" arguments _ arguments veryDeepCopyWith: deepCopier. argumentsProvider _ argumentsProvider veryDeepCopyWith: deepCopier. argumentsSelector _ argumentsSelector. " a Symbol" ! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'ar 8/16/2001 11:24'! mouseUp: evt showSelectionFeedback _ false. borderColor isColor ifFalse:[borderColor _ #raised]. allButtons ifNil: [^ self]. allButtons do: [:m | (m containsPoint: evt cursorPoint) ifTrue: [m performAction]]. allButtons _ nil. self changed. ! ! !PluggableButtonMorph methodsFor: 'events' stamp: 'ar 8/16/2001 11:24'! updateFeedbackForEvt: evt | newState | newState _ self containsPoint: evt cursorPoint. newState = showSelectionFeedback ifFalse: [ borderColor isColor ifTrue:[showSelectionFeedback _ newState] ifFalse:[borderColor _ newState ifTrue:[#inset] ifFalse:[#raised]]. self changed]. ! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:39'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:29'! defaultColor "answer the default color/fill style for the receiver" ^ Color lightGreen! ! !PluggableButtonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:35'! initialize "initialize the state of the receiver" super initialize. "" self listDirection: #topToBottom. self hResizing: #shrinkWrap. "<--so naked buttons work right" self vResizing: #shrinkWrap. self wrapCentering: #center; cellPositioning: #topCenter. model _ nil. label _ nil. getStateSelector _ nil. actionSelector _ nil. getLabelSelector _ nil. getMenuSelector _ nil. shortcutCharacter _ nil. askBeforeChanging _ false. triggerOnMouseDown _ false. onColor _ self color darker. offColor _ self color. feedbackColor _ Color red. showSelectionFeedback _ false. allButtons _ nil. argumentsProvider _ nil. argumentsSelector _ nil. self extent: 20 @ 15! ! !PluggableButtonMorph methodsFor: 'initialize-release' stamp: 'gk 9/22/2003 09:10'! on: anObject getState: getStateSel action: actionSel label: labelSel menu: menuSel self model: anObject. getStateSelector _ getStateSel. actionSelector _ actionSel. getLabelSelector _ labelSel. getMenuSelector _ menuSel. self update: labelSel. ! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:40'! getMenu: shiftPressed "Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector isNil ifTrue: [^nil]. menu := MenuMorph new defaultTarget: model. getMenuSelector numArgs = 1 ifTrue: [^model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^model perform: getMenuSelector with: menu with: shiftPressed]. ^self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'dgd 2/21/2003 22:41'! getModelState "Answer the result of sending the receiver's model the getStateSelector message." ^ getStateSelector isNil ifTrue: [false] ifFalse: [model perform: getStateSelector]! ! !PluggableButtonMorph commentStamp: '<historical>' prior: 0! A PluggableButtonMorph is a combination of an indicator for a boolean value stored in its model and an action button. The action of a button is often, but not always, to toggle the boolean value that it shows. Its pluggable selectors are: getStateSelector fetch a boolean value from the model actionSelector invoke this button's action on the model getLabelSelector fetch this button's lable from the model getMenuSelector fetch a pop-up menu for this button from the model Any of the above selectors can be nil, meaning that the model does not supply behavior for the given action, and the default behavior should be used. For example, if getStateSelector is nil, then this button shows the state of a read-only boolean that is always false. The model informs its view(s) of changes by sending #changed: to itself with getStateSelector as a parameter. The view tells the model when the button is pressed by sending actionSelector. If the actionSelector takes one or more arguments, then the following are relevant: arguments A list of arguments to provide when the actionSelector is called. argumentsProvider The object that is sent the argumentSelector to obtain arguments, if dynamic argumentsSelector The message sent to the argumentProvider to obtain the arguments. Options: askBeforeChanging have model ask user before allowing a change that could lose edits triggerOnMouseDown do this button's action on mouse down (vs. up) transition shortcutCharacter a place to record an optional shortcut key ! !PluggableButtonView methodsFor: 'initialize-release' stamp: 'sw 2/17/2002 05:32'! on: anObject getState: getStateSel action: actionSel getArguments: getArgumentsSel from: argsProvidor label: labelSel menu: menuSel self initialize. self model: anObject. getStateSelector _ getStateSel. actionSelector _ actionSel. argumentsSelector _ getArgumentsSel. argumentsProvider _ argsProvidor. getLabelSelector _ labelSel. getMenuSelector _ menuSel! ! !PluggableButtonView methodsFor: 'accessing' stamp: 'nk 4/17/2004 19:49'! label: aStringOrDisplayObject "Label this button with the given String or DisplayObject." ((aStringOrDisplayObject isKindOf: Paragraph) or: [aStringOrDisplayObject isForm]) ifTrue: [label _ aStringOrDisplayObject] ifFalse: [label _ aStringOrDisplayObject asParagraph]. self centerLabel. ! ! !PluggableButtonView methodsFor: 'other' stamp: 'sw 2/17/2002 05:32'! performAction "Inform the model that this button has been pressed. Sent by the controller when this button is pressed." argumentsSelector ifNil: [actionSelector ifNotNil: [model perform: actionSelector]] ifNotNil: [model perform: actionSelector withArguments: (Array with: (argumentsProvider perform: argumentsSelector))]! ! !PluggableButtonView methodsFor: 'private' stamp: 'nk 4/17/2004 19:49'! centerAlignLabelWith: aPoint "Align the center of the label with aPoint." | alignPt | alignPt _ label boundingBox center. (label isKindOf: Paragraph) ifTrue: [alignPt _ alignPt + (0@(label textStyle leading))]. (label isForm) ifTrue: [label offset: 0 @ 0]. label align: alignPt with: aPoint ! ! !PluggableButtonView class methodsFor: 'instance creation' stamp: 'sumim 2/15/2002 17:18'! on: anObject getState: getStateSel action: actionSel getArguments: getArgumentsSel from: argsProvidor ^ self new on: anObject getState: getStateSel action: actionSel getArguments: getArgumentsSel from: argsProvidor label: nil menu: nil! ! !PluggableCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:46'! roundCornersOf: aMorph in: bounds during: aBlock aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !PluggableCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c self apply: [ :clippedCanvas | clippedCanvas drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'asm 8/25/2003 18:37'! fileSelectedMenu: aMenu | firstItems secondItems thirdItems n1 n2 n3 services | firstItems _ self itemsForFile: self fullName asLowercase. secondItems _ self itemsForAnyFile. thirdItems _ self itemsForNoFile. n1 _ firstItems size. n2 _ n1 + secondItems size. n3 _ n2 + thirdItems size. services _ firstItems, secondItems, thirdItems, (OrderedCollection with: (SimpleServiceEntry provider: self label: 'more...' selector: #offerAllFileOptions)). ^ aMenu addServices2: services for: self extraLines: (Array with: n1 with: n2 with: n3) ! ! !PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'ar 3/18/2001 00:55'! startUpWithCaption: captionOrNil "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." ^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor cursorPoint]).! ! !PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'BG 12/13/2002 15:31'! newFileMenu: aDirectory "For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult" ^(self getFilePathNameDialogWithExistenceCheck) resultBlock: self sfmResultBlock; directory: aDirectory; yourself! ! !PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'BG 12/13/2002 15:32'! oldFileMenu: aDirectory "For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult" ^(self getFilePathNameDialog) resultBlock: self sfmResultBlock; directory: aDirectory; yourself! ! !PluggableListControllerOfMany methodsFor: 'control defaults' stamp: 'tpr 10/4/2001 22:19'! redButtonActivity | selection firstHit turningOn lastSelection pt scrollFlag | model okToChange ifFalse: [^ self]. "Don't change selection if model refuses to unlock" firstHit _ true. scrollFlag _ false. lastSelection _ 0. [sensor redButtonPressed] whileTrue: [selection _ view findSelection: (pt _ sensor cursorPoint). selection == nil ifTrue: "Maybe out of box - check for auto-scroll" [pt y < view insetDisplayBox top ifTrue: [self scrollView: view list lineGrid. scrollFlag _ true. selection _ view firstShown]. pt y > view insetDisplayBox bottom ifTrue: [self scrollView: view list lineGrid negated. scrollFlag _ true. selection _ view lastShown]]. (selection == nil or: [selection = lastSelection]) ifFalse: [firstHit ifTrue: [firstHit _ false. turningOn _ (view listSelectionAt: selection) not]. view selection: selection. (view listSelectionAt: selection) == turningOn ifFalse: [view displaySelectionBox. view listSelectionAt: selection put: turningOn]. lastSelection _ selection]]. selection notNil ifTrue: ["Normal protocol delivers change, so unchange first (ugh)" view listSelectionAt: selection put: (view listSelectionAt: selection) not. self changeModelSelection: selection]. scrollFlag ifTrue: [self moveMarker]! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! asString string ifNotNil:[^string]. getStringSelector ifNil:[^super asString]. ^self sendToModel: getStringSelector ! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! contents getContentsSelector ifNil:[^#()]. ^self sendToModel: getContentsSelector.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! getContentsSelector ^getContentsSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:50'! getContentsSelector: aSymbol self validateSelector: aSymbol. getContentsSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:48'! getStringSelector ^getStringSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! getStringSelector: aSymbol self validateSelector: aSymbol. getStringSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:53'! hasContents hasContentsSelector ifNil:[^super hasContents]. ^self sendToModel: hasContentsSelector ! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! hasContentsSelector ^hasContentsSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! hasContentsSelector: aSymbol self validateSelector: aSymbol. hasContentsSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'! item ^item! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:49'! item: newItem item := newItem! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string ^string! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string: aString string := aString! ! !PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:47'! sendToModel: aSelector aSelector numArgs = 0 ifTrue:[^model perform: aSelector]. aSelector numArgs = 1 ifTrue:[^model perform: aSelector with: item]. aSelector numArgs = 2 ifTrue:[^model perform: aSelector with: item with: self].! ! !PluggableListItemWrapper methodsFor: 'private' stamp: 'ar 10/11/2003 21:50'! validateSelector: aSymbol (aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! ! !PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! ! !PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51' prior: 0! luggableListItemWrapper makes it more easy for clients to use hierarchical lists. Rather than having to write a subclass of ListItemWrapper, a PluggableListItemWrapper can be used to provide the appropriate information straight from the model: string - an explicit string representation (contrary to the 'item' which contains any kind of object) getStringSelector - a message invoked to retrieve the sting representation of its item dynamically from its model (when a constant representation is undesirable) hasContentsSelector - a message invoked in the model to answer whether the item has any children or not. getContentsSelector - a message invoked in the model to retrieve the contents for its item. All callback selectors can have zero, one or two arguments with the item and the wrapper as first and second argument.! !PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/15/2001 22:31'! highlightSelector: aSelector self setProperty: #highlightSelector toValue: aSelector. self updateList! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'ar 3/17/2001 15:32'! itemFromPoint: aPoint "Return the list element (morph) at the given point or nil if outside" | ptY | scroller hasSubmorphs ifFalse:[^nil]. (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. ptY _ (scroller firstSubmorph point: aPoint from: self) y. "note: following assumes that submorphs are vertical, non-overlapping, and ordered" scroller firstSubmorph top > ptY ifTrue:[^nil]. scroller lastSubmorph bottom < ptY ifTrue:[^nil]. "now use binary search" ^scroller findSubmorphBinary:[:item| (item top <= ptY and:[item bottom >= ptY]) ifTrue:[0] "found" ifFalse:[ (item top + item bottom // 2) > ptY ifTrue:[-1] ifFalse:[1]]]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:31'! rowAtLocation: aPoint "Return the row at the given point or 0 if outside" | pointInListMorphCoords | pointInListMorphCoords := (self scroller transformFrom: self) transform: aPoint. ^self listMorph rowAtLocation: pointInListMorphCoords.! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/22/2001 23:56'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto a morph that has agreed to accept the dropped morph by responding 'true' to the wantsDroppedMorph:Event: message. The default implementation just adds the given morph to the receiver." "Here we let the model do its work." self model acceptDroppingMorph: aMorph event: evt inMorph: self. self resetPotentialDropRow. evt hand releaseMouseFocus: self. Cursor normal show. ! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! potentialDropItem "return the item that the most recent drop hovered over, or nil if there is no potential drop target" self potentialDropRow = 0 ifTrue: [ ^self ]. ^self getListItem: self potentialDropRow! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:10'! potentialDropRow "return the row of the item that the most recent drop hovered over, or 0 if there is no potential drop target" ^potentialDropRow ifNil: [ 0 ]. ! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! resetPotentialDropRow potentialDropRow ifNotNil: [ potentialDropRow ~= 0 ifTrue: [ potentialDropRow _ 0. self changed. ] ]! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'nk 6/13/2004 07:09'! startDrag: evt | ddm draggedItem draggedItemMorph passenger | evt hand hasSubmorphs ifTrue: [^ self]. [(self dragEnabled and: [model okToChange]) ifFalse: [^ self]. (draggedItem := self selection) ifNil: [^ self]. draggedItemMorph := StringMorph contents: draggedItem asStringOrText. passenger := self model dragPassengerFor: draggedItemMorph inMorph: self. passenger ifNil: [^ self]. ddm := TransferMorph withPassenger: passenger from: self. ddm dragTransferType: (self model dragTransferTypeForMorph: self). Preferences dragNDropWithAnimation ifTrue: [self model dragAnimationFor: draggedItemMorph transferMorph: ddm]. evt hand grabMorph: ddm] ensure: [Cursor normal show. evt hand releaseMouseFocus: self]! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'! highlightSelection! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'ls 5/17/2001 20:53'! unhighlightSelection ! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:05'! handlesMouseOverDragging: evt ^self dropEnabled! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'nk 8/6/2003 11:38'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus changes. The given argument indicates that the receiver is gaining (versus losing) the keyboard focus. In this case, all we need to do is to redraw border feedback" (self innerBounds areasOutside: (self innerBounds insetBy: 1)) do: [ :rect | self invalidRect: rect ]! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 5/16/2001 22:28'! doubleClick: event | index | doubleClickSelector isNil ifTrue: [^super doubleClick: event]. index _ self rowAtLocation: event position. index = 0 ifTrue: [^super doubleClick: event]. "selectedMorph ifNil: [self setSelectedMorph: aMorph]." ^ self model perform: doubleClickSelector! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:08'! handleBasicKeys: aBoolean "set whether the list morph should handle basic keys like arrow keys, or whether everything should be passed to the model" handlesBasicKeys _ aBoolean! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:09'! handlesBasicKeys " if ya don't want the list to automatically handle non-modifier key (excluding shift key) input, return false" ^ handlesBasicKeys ifNil: [ true ]! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 10/14/2001 13:28'! mouseDown: evt | selectors row | evt yellowButtonPressed "First check for option (menu) click" ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. row _ self rowAtLocation: evt position. row = 0 ifTrue: [^super mouseDown: evt]. "self dragEnabled ifTrue: [aMorph highlightForMouseDown]." selectors _ Array with: #click: with: (doubleClickSelector ifNotNil:[#doubleClick:]) with: nil with: (self dragEnabled ifTrue:[#startDrag:] ifFalse:[nil]). evt hand waitForClicksOrDrag: self event: evt selectors: selectors threshold: 10 "pixels".! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:58'! mouseEnterDragging: evt (evt hand hasSubmorphs and:[self dropEnabled]) ifFalse: ["no d&d" ^super mouseEnterDragging: evt]. (self wantsDroppedMorph: evt hand firstSubmorph event: evt ) ifTrue:[ potentialDropRow _ self rowAtLocation: evt position. evt hand newMouseFocus: self. self changed. "above is ugly but necessary for now" ]. ! ! !PluggableListMorph methodsFor: 'events' stamp: 'nk 8/6/2003 11:25'! mouseLeave: event "The mouse has left the area of the receiver" super mouseLeave: event. event hand releaseKeyboardFocus: self! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:56'! mouseLeaveDragging: anEvent (self dropEnabled and:[anEvent hand hasSubmorphs]) ifFalse: ["no d&d" ^ super mouseLeaveDragging: anEvent]. self resetPotentialDropRow. anEvent hand releaseMouseFocus: self. "above is ugly but necessary for now" ! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 23:55'! mouseMove: evt (self dropEnabled and:[evt hand hasSubmorphs]) ifFalse:[^super mouseMove: evt]. potentialDropRow ifNotNil:[ potentialDropRow = (self rowAtLocation: evt position) ifTrue:[^self]. ]. self mouseLeaveDragging: evt. (self containsPoint: evt position) ifTrue:[self mouseEnterDragging: evt].! ! !PluggableListMorph methodsFor: 'events' stamp: 'ls 6/22/2001 22:49'! mouseUp: event "The mouse came up within the list; take appropriate action" | row | row _ self rowAtLocation: event position. "aMorph ifNotNil: [aMorph highlightForMouseDown: false]." model okToChange ifFalse: [^ self]. (autoDeselect == false and: [row == 0]) ifTrue: [^ self]. "work-around the no-mans-land bug" "No change if model is locked" ((autoDeselect == nil or: [autoDeselect]) and: [row == self selectionIndex]) ifTrue: [self changeModelSelection: 0] ifFalse: [self changeModelSelection: row]. Cursor normal show. ! ! !PluggableListMorph methodsFor: 'events-processing' stamp: 'ar 3/17/2001 16:16'! handleMouseMove: anEvent "Reimplemented because we really want #mouseMove when a morph is dragged around" anEvent wasHandled ifTrue:[^self]. "not interested" (anEvent anyButtonPressed and:[anEvent hand mouseFocus == self]) ifFalse:[^self]. anEvent wasHandled: true. self mouseMove: anEvent. (self handlesMouseStillDown: anEvent) ifTrue:[ "Step at the new location" self startStepping: #handleMouseStillDown: at: Time millisecondClockValue arguments: {anEvent copy resetHandlerFields} stepTime: 1]. ! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 15:33'! extent: newExtent super extent: newExtent. "Change listMorph's bounds to the new width. It is either the size of the widest list item, or the size of self, whatever is bigger" self listMorph width: ((self width max: listMorph hUnadjustedScrollRange) + 20). ! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'ls 5/17/2001 21:01'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled." ^ self font height! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'sps 3/9/2004 17:31'! scrollDeltaWidth "A guess -- assume that the width of a char is approx 1/2 the height of the font" ^ self scrollDeltaHeight // 2 ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font ^ self listMorph font ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font: aFontOrNil self listMorph font: aFontOrNil. ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:15'! getListElementSelector: aSymbol "specify a selector that can be used to obtain a single element in the underlying list" getListElementSelector := aSymbol. list := nil. "this cache will not be updated if getListElementSelector has been specified, so go ahead and remove it"! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/9/2002 01:03'! getListSelector: sel "Set the receiver's getListSelector as indicated, and trigger a recomputation of the list" getListSelector _ sel. self changed. self updateList.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/22/2001 18:21'! getListSizeSelector: aSymbol "specify a selector that can be used to specify the list's size" getListSizeSelector := aSymbol! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 16:29'! list: listOfStrings "lex doesn't think this is used any longer, but is not yet brave enough to remove it. It should be removed eventually" "Set the receiver's list as specified" | morphList h loc index converter item aSelector textColor font | scroller removeAllMorphs. list _ listOfStrings ifNil: [Array new]. list isEmpty ifTrue: [self setScrollDeltas. ^ self selectedMorph: nil]. "NOTE: we will want a quick StringMorph init message, possibly even combined with event install and positioning" font ifNil: [font _ Preferences standardListFont]. converter _ self valueOfProperty: #itemConversionMethod. converter ifNil: [converter _ #asStringOrText]. textColor _ self valueOfProperty: #textColor. morphList _ list collect: [:each | | stringMorph | item _ each. item _ item perform: converter. stringMorph _ item isText ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)] ifFalse: [StringMorph contents: item font: font]. textColor ifNotNil: [ stringMorph color: textColor ]. stringMorph ]. (aSelector _ self valueOfProperty: #balloonTextSelectorForSubMorphs) ifNotNil: [morphList do: [:m | m balloonTextSelector: aSelector]]. self highlightSelector ifNotNil: [model perform: self highlightSelector with: list with: morphList]. "Lay items out vertically and install them in the scroller" h _ morphList first height "self listItemHeight". loc _ 0@0. morphList do: [:m | m bounds: (loc extent: 9999@h). loc _ loc + (0@h)]. scroller addAllMorphs: morphList. index _ self getCurrentSelectionIndex. self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]). self setScrollDeltas. scrollBar setValue: 0.0! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:31'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel self model: anObject. getListSelector _ getListSel. getIndexSelector _ getSelectionSel. setIndexSelector _ setSelectionSel. getMenuSelector _ getMenuSel. keystrokeActionSelector _ keyActionSel. autoDeselect _ true. self borderWidth: 1. self updateList. self selectionIndex: self getCurrentSelectionIndex. self initForKeystrokes! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:41'! textColor "Answer my default text color." ^self valueOfProperty: #textColor ifAbsent: [ Color black ] ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 2/5/2004 18:02'! textColor: aColor "Set my default text color." self setProperty: #textColor toValue: aColor. self listMorph color: aColor.! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:40'! textHighlightColor "Answer my default text highlight color." ^self valueOfProperty: #textHighlightColor ifAbsent: [ Color red ]. ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'nk 5/16/2003 14:37'! textHighlightColor: aColor "Set my default text highlight color." self setProperty: #textHighlightColor toValue: aColor. ! ! !PluggableListMorph methodsFor: 'menu' stamp: 'tk 12/10/2001 20:33'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | aMenu | aMenu _ super getMenu: shiftKeyState. aMenu ifNotNil: [aMenu commandKeyHandler: self]. ^ aMenu! ! !PluggableListMorph methodsFor: 'menus' stamp: 'dgd 8/30/2003 21:56'! addCustomMenuItems: aMenu hand: aHandMorph "Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo." super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addLine. aMenu add: 'list font...' translated target: self action: #setListFont. aMenu add: 'copy list to clipboard' translated target: self action: #copyListToClipboard. aMenu add: 'copy selection to clipboard' translated target: self action: #copySelectionToClipboard! ! !PluggableListMorph methodsFor: 'menus' stamp: 'nk 3/26/2002 08:49'! copyListToClipboard "Copy my items to the clipboard as a multi-line string" | stream | stream _ WriteStream on: (String new: list size * 40). list do: [:ea | stream nextPutAll: ea asString] separatedBy: [stream nextPut: Character cr]. Clipboard clipboardText: stream contents! ! !PluggableListMorph methodsFor: 'menus' stamp: 'sw 3/31/2002 02:38'! copySelectionToClipboard "Copy my selected item to the clipboard as a string" self selection ifNotNil: [Clipboard clipboardText: self selection asString] ifNil: [self flash]! ! !PluggableListMorph methodsFor: 'menus' stamp: 'nk 9/1/2004 10:48'! setListFont "set the font for the list" Preferences chooseFontWithPrompt: 'Choose the font for this list' translated andSendTo: self withSelector: #font: highlight: self listMorph font! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/23/2001 00:45'! basicKeyPressed: aChar | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | nextSelection _ oldSelection _ self getCurrentSelectionIndex. max _ self maximumSelection. milliSeconds _ Time millisecondClockValue. milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" lastKeystrokes _ '']. lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. lastKeystrokeTime _ milliSeconds. nextSelectionList _ OrderedCollection newFrom: (self getList copyFrom: oldSelection + 1 to: max). nextSelectionList addAll: (self getList copyFrom: 1 to: oldSelection). "Get rid of blanks and style used in some lists" nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] ifNone: [^ self flash"match not found"]. model okToChange ifFalse: [^ self]. nextSelection _ self getList findFirst: [:a | a == nextSelectionText]. "No change if model is locked" oldSelection == nextSelection ifTrue: [^ self flash]. ^ self changeModelSelection: nextSelection! ! !PluggableListMorph methodsFor: 'model access' stamp: 'sw 12/4/2001 20:51'! commandKeyTypedIntoMenu: evt "The user typed a command-key into a menu which has me as its command-key handler" ^ self modifierKeyPressed: evt keyCharacter! ! !PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'! getCurrentSelectionIndex "Answer the index of the current selection." getIndexSelector isNil ifTrue: [^0]. ^model perform: getIndexSelector! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 14:16'! getList "Answer the list to be displayed. Caches the returned list in the 'list' ivar" getListSelector == nil ifTrue: [^ #()]. list _ model perform: getListSelector. list == nil ifTrue: [^ #()]. list _ list collect: [ :item | item asStringOrText ]. ^ list! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 7/1/2001 10:39'! getListItem: index "get the index-th item in the displayed list" getListElementSelector ifNotNil: [ ^(model perform: getListElementSelector with: index) asStringOrText ]. list ifNotNil: [ ^list at: index ]. ^self getList at: index! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 5/17/2001 22:04'! getListSize "return the current number of items in the displayed list" getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. ^self getList size! ! !PluggableListMorph methodsFor: 'model access' stamp: 'ls 6/10/2001 12:26'! itemSelectedAmongMultiple: index "return whether the index-th row is selected. Always false in PluggableListMorph, but sometimes true in PluggableListMorphOfMany" ^false! ! !PluggableListMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:05'! modifierKeyPressed: aChar | args | keystrokeActionSelector isNil ifTrue: [^nil]. args := keystrokeActionSelector numArgs. args = 1 ifTrue: [^model perform: keystrokeActionSelector with: aChar]. args = 2 ifTrue: [^model perform: keystrokeActionSelector with: aChar with: self]. ^self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! !PluggableListMorph methodsFor: 'model access' stamp: 'sw 12/9/2001 18:54'! specialKeyPressed: asciiValue "A special key with the given ascii-value was pressed; dispatch it" | oldSelection nextSelection max howManyItemsShowing | asciiValue = 27 ifTrue: [" escape key" ^ ActiveEvent shiftPressed ifTrue: [ActiveWorld putUpWorldMenuFromEscapeKey] ifFalse: [self yellowButtonActivity: false]]. max _ self maximumSelection. max > 0 ifFalse: [^ self]. nextSelection _ oldSelection _ self getCurrentSelectionIndex. asciiValue = 31 ifTrue: [" down arrow" nextSelection _ oldSelection + 1. nextSelection > max ifTrue: [nextSelection _ 1]]. asciiValue = 30 ifTrue: [" up arrow" nextSelection _ oldSelection - 1. nextSelection < 1 ifTrue: [nextSelection _ max]]. asciiValue = 1 ifTrue: [" home" nextSelection _ 1]. asciiValue = 4 ifTrue: [" end" nextSelection _ max]. howManyItemsShowing _ self numSelectionsInView. asciiValue = 11 ifTrue: [" page up" nextSelection _ 1 max: oldSelection - howManyItemsShowing]. asciiValue = 12 ifTrue: [" page down" nextSelection _ oldSelection + howManyItemsShowing min: max]. model okToChange ifFalse: [^ self]. "No change if model is locked" oldSelection = nextSelection ifTrue: [^ self flash]. ^ self changeModelSelection: nextSelection! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! doubleClick: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! mouseDown: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseEnterDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseLeaveDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseUp: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! removeObsoleteEventHandlers scroller submorphs do:[:m| m eventHandler: nil; highlightForMouseDown: false; resetExtension].! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! startDrag: evt onItem: itemMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 5/17/2001 23:06'! maximumSelection ^ self getListSize! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/16/2001 14:15'! scrollSelectionIntoView "make sure that the current selection is visible" | row | row := self getCurrentSelectionIndex. row = 0 ifTrue: [ ^ self ]. self scrollToShow: (self listMorph drawBoundsForRow: row)! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:20'! selectedMorph "this doesn't work with the LargeLists patch!! Use #selectionIndex and #selection instead." ^self scroller submorphs at: self selectionIndex! ! !PluggableListMorph methodsFor: 'selection' stamp: 'nk 7/30/2004 17:53'! selectedMorph: aMorph "this shouldn't be used any longer" "self isThisEverCalled ." Beeper beep. true ifTrue: [^self]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 8/19/2001 14:29'! selection self selectionIndex = 0 ifTrue: [ ^nil ]. list ifNotNil: [ ^list at: self selectionIndex ]. ^ self getListItem: self selectionIndex! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'! selection: item "Called from outside to request setting a new selection." self selectionIndex: (self getList indexOf: item)! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:49'! selectionIndex "return the index we have currently selected, or 0 if none" ^self listMorph selectedRow ifNil: [ 0 ]! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 6/22/2001 22:50'! selectionIndex: index "Called internally to select the index-th item." | row | self unhighlightSelection. row := index ifNil: [ 0 ]. row := row min: self getListSize. "make sure we don't select past the end" self listMorph selectedRow: row. self highlightSelection. self scrollSelectionIntoView.! ! !PluggableListMorph methodsFor: 'submorphs-accessing' stamp: 'di 11/14/2001 13:57'! allSubmorphNamesDo: nameBlock "Assume list morphs do not have named parts -- saves MUCH time" ^ self! ! !PluggableListMorph methodsFor: 'updating' stamp: 'ls 5/15/2001 22:31'! update: aSymbol "Refer to the comment in View|update:." aSymbol == getListSelector ifTrue: [self updateList. ^ self]. aSymbol == getIndexSelector ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self]. ! ! !PluggableListMorph methodsFor: 'updating' stamp: 'ls 6/22/2001 23:56'! updateList | index | "the list has changed -- update from the model" self listMorph listChanged. self setScrollDeltas. scrollBar setValue: 0.0. index _ self getCurrentSelectionIndex. self resetPotentialDropRow. self selectionIndex: index. ! ! !PluggableListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:36'! verifyContents "Verify the contents of the receiver, reconstituting if necessary. Called whenever window is reactivated, to react to possible structural changes. Also called periodically in morphic if the smartUpdating preference is true" | newList existingSelection anIndex oldList | oldList _ list ifNil: [ #() ]. newList _ self getList. ((oldList == newList) "fastest" or: [oldList = newList]) ifTrue: [^ self]. self flash. "list has changed beneath us; give the user a little visual feedback that the contents of the pane are being updated." existingSelection _ self selectionIndex > 0 ifTrue: [ oldList at: self selectionIndex ] ifFalse: [ nil ]. self updateList. (existingSelection notNil and: [(anIndex _ list indexOf: existingSelection asStringOrText ifAbsent: [nil]) notNil]) ifTrue: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifFalse: [self changeModelSelection: 0]! ! !PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 2/5/2004 18:01'! listMorph listMorph ifNil: [ "crate this lazily, in case the morph is legacy" listMorph := self listMorphClass new. listMorph listSource: self. listMorph width: self scroller width. listMorph color: self textColor ]. listMorph owner ~~ self scroller ifTrue: [ "list morph needs to be installed. Again, it's done this way to accomodate legacy PluggableListMorphs" self scroller removeAllMorphs. self scroller addMorph: listMorph ]. ^listMorph! ! !PluggableListMorph methodsFor: 'as yet unclassified' stamp: 'ls 5/17/2001 09:04'! listMorphClass ^LazyListMorph! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/24/2002 18:31'! hExtraScrollRange "Return the amount of extra blank space to include to the right of the scroll content." ^5 ! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 3/9/2004 15:18'! hUnadjustedScrollRange "Return the width of the widest item in the list" ^self listMorph hUnadjustedScrollRange ! ! !PluggableListMorph methodsFor: 'scrolling' stamp: 'sps 12/26/2002 13:36'! vUnadjustedScrollRange "Return the height extent of the receiver's submorphs." (scroller submorphs size > 0) ifFalse:[ ^0 ]. ^(scroller submorphs last fullBounds bottom) ! ! !PluggableListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:52'! list: arrayOfStrings "Set the receivers items to be the given list of strings." "Note: the instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list." "NOTE: this is no longer true; list is a real list, and itemList is no longer used. And this method shouldn't be called, incidentally." self isThisEverCalled . itemList _ arrayOfStrings. ^ super list: arrayOfStrings! ! !PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:58'! changeModelSelection: anInteger "Change the model's selected item to be the one at the given index." | item | setIndexSelector ifNotNil: [ item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). model perform: setIndexSelector with: item]. self update: getIndexSelector. ! ! !PluggableListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:51'! getCurrentSelectionIndex "Answer the index of the current selection." | item | getIndexSelector == nil ifTrue: [^ 0]. item _ model perform: getIndexSelector. ^ list findFirst: [ :x | x = item] ! ! !PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'ls 8/19/2001 15:57'! getList "cache the raw items in itemList" itemList := getListSelector ifNil: [ #() ] ifNotNil: [ model perform: getListSelector ]. ^super getList! ! !PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:26'! listSelectionAt: index getSelectionListSelector ifNil:[^false]. ^model perform: getSelectionListSelector with: index! ! !PluggableListMorphOfMany methodsFor: 'drawing' stamp: 'tpr 10/4/2001 21:27'! listSelectionAt: index put: value setSelectionListSelector ifNil:[^false]. ^model perform: setSelectionListSelector with: index with: value! ! !PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'ls 7/15/2002 11:16'! mouseDown: event | oldIndex oldVal row | event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed]. row := self rowAtLocation: event position. row = 0 ifTrue: [^super mouseDown: event]. model okToChange ifFalse: [^ self]. "No change if model is locked" "Set meaning for subsequent dragging of selection" dragOnOrOff _ (self listSelectionAt: row) not. oldIndex _ self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [oldVal _ self listSelectionAt: oldIndex]. "Set or clear new primary selection (listIndex)" dragOnOrOff ifTrue: [self changeModelSelection: row] ifFalse: [self changeModelSelection: 0]. "Need to restore the old one, due to how model works, and set new one." oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. self listSelectionAt: row put: dragOnOrOff. "event hand releaseMouseFocus: aMorph." "aMorph changed"! ! !PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'nk 10/14/2003 22:19'! mouseMove: event "The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate" | oldIndex oldVal row | event position y < self top ifTrue: [scrollBar scrollUp: 1. row := self rowAtLocation: scroller topLeft + (1 @ 1)] ifFalse: [row := event position y > self bottom ifTrue: [scrollBar scrollDown: 1. self rowAtLocation: scroller bottomLeft + (1 @ -1)] ifFalse: [ self rowAtLocation: event position]]. row = 0 ifTrue: [^super mouseDown: event]. model okToChange ifFalse: [^self]. "No change if model is locked" dragOnOrOff ifNil: ["Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item" dragOnOrOff := (self listSelectionAt: row) not]. "Set meaning for subsequent dragging of selection" oldIndex := self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [oldVal := self listSelectionAt: oldIndex]. "Set or clear new primary selection (listIndex)" dragOnOrOff ifTrue: [self changeModelSelection: row] ifFalse: [self changeModelSelection: 0]. "Need to restore the old one, due to how model works, and set new one." oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal]. self listSelectionAt: row put: dragOnOrOff. row changed! ! !PluggableListMorphOfMany methodsFor: 'event handling' stamp: 'ar 3/17/2001 16:23'! mouseUp: event dragOnOrOff _ nil. "So improperly started drags will have not effect"! ! !PluggableListMorphOfMany methodsFor: 'initialization' stamp: 'ar 3/17/2001 17:07'! list: listOfStrings scroller removeAllMorphs. list _ listOfStrings ifNil: [Array new]. list isEmpty ifTrue: [^ self selectedMorph: nil]. super list: listOfStrings. "At this point first morph is sensitized, and all morphs share same handler." scroller firstSubmorph on: #mouseEnterDragging send: #mouseEnterDragging:onItem: to: self. scroller firstSubmorph on: #mouseUp send: #mouseUp:onItem: to: self. "This should add this behavior to the shared event handler thus affecting all items"! ! !PluggableListMorphOfMany methodsFor: 'initialization' stamp: 'tpr 10/4/2001 21:24'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel "setup a whole load of pluggability options" getSelectionListSelector _ getListSel. setSelectionListSelector _ setListSel. super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel ! ! !PluggableListMorphOfMany methodsFor: 'model access' stamp: 'hpt 4/5/2004 11:00'! itemSelectedAmongMultiple: index ^self listSelectionAt: index! ! !PluggableListMorphOfMany commentStamp: 'hpt 4/5/2004 11:21' prior: 0! A variant of its superclass that allows multiple items to be selected simultaneously. There is still a distinguished element which is selected, but each other element in the list may be flagged on or off. ! !PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:54'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: #arrowKey:from: "default"! ! !PluggableListMorphOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/4/2001 21:52'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel! ! !PluggableListView methodsFor: 'initialization' stamp: 'di 6/20/2001 09:58'! list: arrayOfStrings "Set the receivers items to be the given list of strings The instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list." ((items == arrayOfStrings) "fastest" or: [items = arrayOfStrings]) ifTrue: [^ self]. items _ arrayOfStrings. isEmpty _ arrayOfStrings isEmpty. "add top and bottom delimiters" list _ ListParagraph withArray: (Array streamContents: [:s | s nextPut: topDelimiter. arrayOfStrings do: [:item | item == nil ifFalse: [(item isMemberOf: MethodReference) "A very specific fix for MVC" ifTrue: [s nextPut: item asStringOrText] ifFalse: [s nextPut: item]]]. s nextPut: bottomDelimiter]) style: self assuredTextStyle. selection _ self getCurrentSelectionIndex. self positionList.! ! !PluggableListView methodsFor: 'model access' stamp: 'nk 6/29/2004 14:45'! handleKeystroke: aChar "Answer the menu for this list view." | args aSpecialKey | aSpecialKey _ aChar asciiValue. aSpecialKey < 32 ifTrue: [ self specialKeyPressed: aSpecialKey. ^nil ]. keystrokeActionSelector ifNil: [^ nil]. controller controlTerminate. (args _ keystrokeActionSelector numArgs) = 1 ifTrue: [model perform: keystrokeActionSelector with: aChar. ^ controller controlInitialize]. args = 2 ifTrue: [model perform: keystrokeActionSelector with: aChar with: self. ^ controller controlInitialize]. ^ self error: 'The keystrokeActionSelector must be a 1- or 2-keyword symbol'! ! !PluggableListView methodsFor: 'model access' stamp: 'nk 6/29/2004 14:42'! specialKeyPressed: keyEvent "Process the up and down arrows in a list pane." | oldSelection nextSelection max min howMany | (#(1 4 11 12 30 31) includes: keyEvent) ifFalse: [ ^ false ]. oldSelection := self getCurrentSelectionIndex. nextSelection := oldSelection. max := self maximumSelection. min := self minimumSelection. howMany := self numSelectionsInView. "get this exactly??" keyEvent == 31 ifTrue: ["down-arrow; move down one, wrapping to top if needed" nextSelection := oldSelection + 1. nextSelection > max ifTrue: [nextSelection _ 1]]. keyEvent == 30 ifTrue: ["up arrow; move up one, wrapping to bottom if needed" nextSelection := oldSelection - 1. nextSelection < 1 ifTrue: [nextSelection _ max]]. keyEvent == 1 ifTrue: [nextSelection := 1]. "home" keyEvent == 4 ifTrue: [nextSelection := max]. "end" keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection - howMany)]. "page up" keyEvent == 12 ifTrue: [nextSelection := (oldSelection + howMany) min: max]. "page down" nextSelection = oldSelection ifFalse: [model okToChange ifTrue: [self changeModelSelection: nextSelection. "self controller moveMarker"]]. ^true ! ! !PluggableListView methodsFor: 'updating' stamp: 'BG 1/22/2004 13:15'! verifyContents | newItems existingSelection anIndex | "Called on window reactivation to react to possible structural changes. Update contents if necessary." newItems _ self getList. ((items == newItems) "fastest" or: [items = newItems]) ifTrue: [^ self]. self flash. "list has changed beneath us; could get annoying, but hell" existingSelection _ list stringAtLineNumber: (selection + (topDelimiter ifNil: [0] ifNotNil: [1])). "account for cursed ------ row" self list: newItems. (newItems size > 0 and: [newItems first isKindOf: Symbol]) ifTrue: [existingSelection _ existingSelection asSymbol]. (anIndex _ newItems indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector.] ifNil: [self changeModelSelection: 0]. selection := 0. " to display the list without selection " self displayView. self update: getSelectionSelector. ! ! !PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tpr 10/4/2001 21:34'! deEmphasizeView "Refer to the comment in View|deEmphasizeView." selection _ 0. 1 to: self maximumSelection do: [:i | selection _ i. (self listSelectionAt: i) ifTrue: [self deEmphasizeSelectionBox]]. selection _ 0! ! !PluggableListViewOfMany methodsFor: 'displaying' stamp: 'tpr 10/4/2001 21:34'! highlightFrom: start to: stop (start == nil or: [stop == nil]) ifTrue: [^ self displayView]. start to: stop do: [:i | selection _ i. (self listSelectionAt: selection) ifTrue: [self displaySelectionBox]]. selection _ 0! ! !PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tpr 10/4/2001 22:17'! listSelectionAt: index getSelectionListSelector ifNil:[^false]. ^model perform: getSelectionListSelector with: index! ! !PluggableListViewOfMany methodsFor: 'selecting' stamp: 'tpr 10/4/2001 22:17'! listSelectionAt: index put: value setSelectionListSelector ifNil:[^false]. ^model perform: setSelectionListSelector with: index with: value! ! !PluggableListViewOfMany methodsFor: 'initialization' stamp: 'tpr 10/8/2001 20:53'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel "setup a whole load of pluggability options" getSelectionListSelector _ getListSel. setSelectionListSelector _ setListSel. super on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel ! ! !PluggableListViewOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 20:53'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: #arrowKey:from: "default"! ! !PluggableListViewOfMany class methodsFor: 'instance creation' stamp: 'tpr 10/8/2001 20:52'! on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel ^ self new on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel! ! !PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'md 10/20/2004 15:32'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel self model: anObject. getListSelector _ getListSel. getIndexSelector _ getSelectionSel. setIndexSelector _ setSelectionSel. getMenuSelector _ getMenuSel. keystrokeActionSelector _ keyActionSel. autoDeselect _ true. self borderWidth: 1. getRawListSelector _ getRawSel. self updateList. self selectionIndex: self getCurrentSelectionIndex. self initForKeystrokes! ! !PluggableMessageCategoryListMorph methodsFor: 'model access' stamp: 'ls 8/19/2001 15:35'! getList "Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser. This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method" getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList _ nil. ^ #()]. model classListIndex = 0 ifTrue: [^ priorRawList _ list _ Array new]. priorRawList _ model perform: getRawListSelector. list := (Array with: ClassOrganizer allCategory), priorRawList. ^list! ! !PluggableMessageCategoryListMorph methodsFor: 'updating' stamp: 'ls 8/19/2001 14:26'! verifyContents | newList existingSelection anIndex newRawList | (model editSelection == #editComment) ifTrue: [^ self]. model classListIndex = 0 ifTrue: [^ self]. newRawList _ model perform: getRawListSelector. newRawList == priorRawList ifTrue: [^ self]. "The usual case; very fast" priorRawList _ newRawList. newList _ (Array with: ClassOrganizer allCategory), priorRawList. list = newList ifTrue: [^ self]. self flash. "could get annoying, but hell" existingSelection _ self selection. self updateList. (anIndex _ newList indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifNil: [self changeModelSelection: 0]! ! !PluggableMessageCategoryListMorph class methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 16:59'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/18/2001 10:32'! getListRow: row "return the strings that should appear in the requested row" getListElementSelector ifNotNil: [ ^model perform: getListElementSelector with: row ]. ^self getList collect: [ :l | l at: row ]! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 23:03'! getListSize | l | getListSizeSelector ifNotNil: [ ^model perform: getListSizeSelector ]. l := self getList. l isEmpty ifTrue: [ ^ 0 ]. ^l first size! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'nk 4/5/2001 23:18'! itemFromPoint: aPoint "Return the list element (morph) at the given point or nil if outside" | ptY | scroller hasSubmorphs ifFalse:[^nil]. (scroller fullBounds containsPoint: aPoint) ifFalse:[^nil]. ptY _ (scroller firstSubmorph point: aPoint from: self) y. "note: following assumes that submorphs are vertical, non-overlapping, and ordered" scroller firstSubmorph top > ptY ifTrue:[^nil]. scroller lastSubmorph bottom < ptY ifTrue:[^nil]. "now use binary search" ^scroller submorphThat: [ :item | item top <= ptY and:[item bottom >= ptY] ] ifNone: []. ! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'ls 5/17/2001 20:01'! listMorphClass ^MulticolumnLazyListMorph! ! !PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:22'! createMorphicListsFrom: arrayOfLists | array | array _ Array new: arrayOfLists size. 1 to: arrayOfLists size do: [:arrayIndex | array at: arrayIndex put: ( (arrayOfLists at: arrayIndex) collect: [:item | item isText ifTrue: [StringMorph contents: item font: self font emphasis: (item emphasisAt: 1)] ifFalse: [StringMorph contents: item font: self font]]) ]. ^array! ! !PluggableMultiColumnListMorph methodsFor: 'initialization' stamp: 'ls 5/17/2001 21:16'! list: arrayOfLists | listOfStrings | lists _ arrayOfLists. scroller removeAllMorphs. listOfStrings _ arrayOfLists == nil ifTrue: [Array new] ifFalse: [ arrayOfLists isEmpty ifFalse: [ arrayOfLists at: 1]]. list _ listOfStrings ifNil: [Array new]. self listMorph listChanged.. self setScrollDeltas. scrollBar setValue: 0.0! ! !PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:24'! highlightSelection ^self! ! !PluggableMultiColumnListMorph methodsFor: 'selection' stamp: 'ls 5/16/2001 22:23'! unhighlightSelection ^self! ! !PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 11/14/2002 13:13'! basicKeyPressed: aChar "net supported for multi-column lists; which column should be used?!! The issue is that the base class implementation uses getList expecting a single collectino to come back instead of several of them" ^self! ! !PluggableMultiColumnListMorph methodsFor: 'model access' stamp: 'ls 7/12/2001 23:24'! getList "fetch and answer the lists to be displayed" getListSelector == nil ifTrue: [^ #()]. list _ model perform: getListSelector. list == nil ifTrue: [^ #()]. list _ list collect: [ :column | column collect: [ :item | item asStringOrText ] ]. ^ list! ! !PluggableMultiColumnListMorphByItem methodsFor: 'initialization' stamp: 'ls 8/19/2001 14:55'! list: arrayOfStrings "Set the receivers items to be the given list of strings." "Note: the instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list." "NO LONGER TRUE. list is a real list, and listItems is obsolete." self isThisEverCalled . itemList _ arrayOfStrings first. ^ super list: arrayOfStrings! ! !PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 14:57'! changeModelSelection: anInteger "Change the model's selected item to be the one at the given index." | item | setIndexSelector ifNotNil: [item _ anInteger = 0 ifFalse: [list first at: anInteger]. model perform: setIndexSelector with: item]. self update: getIndexSelector! ! !PluggableMultiColumnListMorphByItem methodsFor: 'model access' stamp: 'ls 8/19/2001 15:11'! getCurrentSelectionIndex "Answer the index of the current selection." | item | getIndexSelector == nil ifTrue: [^ 0]. item _ model perform: getIndexSelector. ^ list first findFirst: [:x | x = item]! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 16:22'! handlesMouseDown: anEvent ^ true! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/2/2004 17:49'! layoutChanged "Fix up our tabs bounds" | tabsCount | super layoutChanged. tabsCount _ self tabs size. tabsCount isZero ifFalse: [ | tabInnerExtent count | tabInnerExtent _ ((self width - ((self tabs first key outerGap + self tabs last key outerGap) // 2) - tabsCount) // tabsCount) @ (self height). count _ 1. self tabs do: [ :anAssociation | | tab | tab _ anAssociation key. tab innerExtent: tabInnerExtent. count = 1 ifTrue: [tab position: self position] ifFalse: [ tab position: (self position translateBy: ((tabInnerExtent x + 1) * (count - 1))@0)]. count _ count + 1 ] ]. self changed.! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'KLC 2/24/2004 15:14'! mouseDown: anEvent | xPosition newTab | xPosition _ anEvent cursorPoint x. newTab _ ((self tabs detect: [ :anAssociation | | tabBounds | tabBounds _ anAssociation key bounds. (tabBounds left <= xPosition) and: [ tabBounds right >= xPosition]] ifNone: [nil]) key). newTab ifNil: [^ self]. newTab = activeTab ifFalse: [ self activeTab: newTab ] ! ! !PluggableTabBarMorph methodsFor: 'actions' stamp: 'tlk 7/17/2004 14:35'! performActiveTabAction "Look up the Symbol or Block associated with the currently active tab, and perform it." | tabActionAssoc aSymbolOrBlock | tabActionAssoc _ self tabs detect: [ :assoc | assoc key = self activeTab.] ifNone: [ Association new ]. aSymbolOrBlock _ tabActionAssoc value. aSymbolOrBlock ifNil: [ ^ false ]. ^ aSymbolOrBlock isSymbol ifTrue: [ self target perform: aSymbolOrBlock ] ifFalse: [ aSymbolOrBlock value ]. ! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 14:17'! activeTab activeTab ifNil: [ self tabs size > 0 ifTrue: [ activeTab _ self tabs first key. activeTab active: true]]. ^ activeTab ! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/24/2004 15:27'! activeTab: aTabMorph self activeTab ifNotNil: [self activeTab toggle]. activeTab _ aTabMorph. self activeTab toggle. aTabMorph delete. self addMorphFront: aTabMorph. self performActiveTabAction. self changed. ! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 13:25'! tabs tabs ifNil: [ tabs _ OrderedCollection new ]. ^ tabs! ! !PluggableTabBarMorph methodsFor: 'private - access' stamp: 'KLC 2/2/2004 10:37'! target ^ target! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/24/2004 15:26'! addTab: aStringOrTextOrMorph withAction: aSymbolOrBlock "Add a new tab. The tab will be added onto the end of the list and displayed on the far right of previously added tabs. The first argument can be a simple String, a Text, or any Morph. The second argument is the action to be performed when the tab is selected. It can either be a symbol for a unary method on the target object or a block. Each tab is stored as an Association with the created tab as the key and the selector as the value." | tabMorph | tabMorph _ PluggableTabButtonMorph on: nil label: [ aStringOrTextOrMorph]. tabMorph color: self color. self addMorphBack: tabMorph. self tabs ifEmpty: [ self activeTab: tabMorph ]. self tabs add: (Association key: tabMorph value: aSymbolOrBlock). self layoutChanged. self changed.! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 17:36'! color: aFillStyle color _ aFillStyle. self tabs do: [ :anAssociation | anAssociation key color: aFillStyle ] ! ! !PluggableTabBarMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 10:37'! target: anObject target _ anObject! ! !PluggableTabBarMorph methodsFor: 'drawing' stamp: 'KLC 2/24/2004 15:10'! drawOn: aCanvas self tabs size > 0 ifFalse: [^ self ]. self tabs do: [ :anAssociation | | tab | tab _ anAssociation key. tab drawOn: aCanvas]! ! !PluggableTabBarMorph commentStamp: 'KLC 9/17/2004 11:26' prior: 0! This morph manages a set of PluggableTabButtonMorphs. Each tab should be added in the left to right order that they should be displayed. Each tab will be evenly sized to fit the available space. This morph intercepts mouse clicks, figures out which tab was clicked, pops up the new tab as the active tab and triggers the registered event. See PluggableTabButtonMorph for information on what a tab can consist of. Example: (PluggableTabBarMorph on: nil) addTab: (Text fromString: 'Test') withAction: [Transcript show: 'Test'; cr]; addTab: (Text fromString: 'Another') withAction: [Transcript show: 'Another'; cr]; width: 200; openInHand ! !PluggableTabBarMorph class methodsFor: 'instance creation' stamp: 'KLC 2/2/2004 10:38'! on: anObject ^ super new target: anObject! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 1/23/2004 15:49'! drawOn: aCanvas self drawTabOn: aCanvas. self drawSubMorphOn: aCanvas! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 9/17/2004 11:24'! drawSubMorphOn: aCanvas | morphBounds | morphBounds _ self bounds insetBy: (self cornerRadius + 3) @ (self topInactiveGap // 2 + 2). morphBounds _ morphBounds translateBy: 0@(self topInactiveGap // 2 + 1). self active ifTrue: [ morphBounds _ morphBounds translateBy: 0@((self topInactiveGap // 2 + 1) negated)]. self subMorph bounds height < (morphBounds height) ifTrue: [ morphBounds _ morphBounds insetBy: 0@((morphBounds height - self subMorph bounds height) // 2)]. self subMorph bounds width < (morphBounds width) ifTrue: [ morphBounds _ morphBounds insetBy: ((morphBounds width - self subMorph bounds width) // 2)@0]. self subMorph bounds: morphBounds. aCanvas drawMorph: self subMorph! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 2/2/2004 15:07'! drawTabOn: aCanvas | top myColor cornerRadius myArcLengths myBounds | cornerRadius _ self cornerRadius. myBounds _ self bounds. self active ifTrue: [ top _ myBounds top. myColor _ self color ] ifFalse: [ top _ myBounds top + self topInactiveGap. myColor _ self color whiter whiter ]. aCanvas fillRectangle: ((myBounds left + cornerRadius) @ (top + cornerRadius) corner: (myBounds right - cornerRadius) @ self bottom) color: myColor. aCanvas fillRectangle: ((myBounds left + (cornerRadius * 2)) @ top corner: (myBounds right - (cornerRadius * 2)) @ (top + cornerRadius)) color: myColor. aCanvas fillOval: ((myBounds left + self cornerRadius) @ top corner: (myBounds left + (self cornerRadius * 3)) @ (top + (self cornerRadius * 2))) color: myColor. aCanvas fillOval: ((myBounds right - (self cornerRadius * 3)) @ top corner: (myBounds right - self cornerRadius) @ (top + (self cornerRadius * 2))) color: myColor. myArcLengths _ self arcLengths. 1 to: myArcLengths size do: [ :i | | length | length _ myArcLengths at: i. aCanvas line: (myBounds left + cornerRadius - i) @ (myBounds bottom - 1 ) to: (myBounds left + cornerRadius - i) @ (myBounds bottom - length - 1) color: myColor. aCanvas line: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - 1) to: (myBounds right - cornerRadius + i - 1) @ (myBounds bottom - length - 1) color: myColor] ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:25'! active active ifNil: [ active _ false ]. ^ active! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:26'! active: aBoolean active _ aBoolean. self changed.! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:05'! innerExtent: aPoint "Set the extent based on the primary visible part of the tab. In other words add twice the cornerRadius to this extent" self extent: (aPoint x + (self cornerRadius * 2)) @ (aPoint y)! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! model ^ model ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! model: anObject model _ anObject! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 2/2/2004 14:07'! outerGap "The horizontal distance of the outer left and right edges of the tab excluding the inner visible part" ^ self cornerRadius * 2! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector ^ textSelector ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector: aSymbol textSelector _ aSymbol! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:36'! arcLengths arcLengths ifNil: [ self calculateArcLengths ]. ^ arcLengths! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:37'! arcLengths: anArrayOfIntegers arcLengths _ anArrayOfIntegers ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! cornerRadius ^ 5 ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph subMorph ifNil: [ self update: self textSelector ]. ^ subMorph! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph: aMorph subMorph _ aMorph ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! topInactiveGap ^ 5! ! !PluggableTabButtonMorph methodsFor: 'precalculations' stamp: 'KLC 1/23/2004 14:46'! calculateArcLengths | array radius | radius _ self cornerRadius. array _ Array new: radius. 1 to: radius do: [ :i | | x | x _ i - 0.5. array at: i put: (radius - ((2 * x * radius) - (x * x)) sqrt) asInteger]. self arcLengths: array! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 2/2/2004 10:15'! step self subMorph step. self changed. ! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! stepTime ^ self subMorph stepTime ! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! wantsSteps ^ self subMorph wantsSteps! ! !PluggableTabButtonMorph methodsFor: 'updating' stamp: 'KLC 1/23/2004 17:02'! update: aSelector self textSelector ifNotNil: [ aSelector = self textSelector ifTrue: [ | morph | (aSelector isSymbol and: [model notNil]) ifTrue: [ morph _ (self model perform: aSelector) asMorph] ifFalse: [ morph _ aSelector value asMorph]. self subMorph: morph]]. self changed! ! !PluggableTabButtonMorph methodsFor: 'initialization' stamp: 'KLC 1/22/2004 16:45'! initialize ^ super initialize ! ! !PluggableTabButtonMorph methodsFor: 'actions' stamp: 'KLC 1/23/2004 15:38'! toggle self active: self active not! ! !PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27' prior: 0! This is a specialized pluggable button morph that is meant to represent a tab in a set of tabs arranged horizontally. Each tab will overlap slightly when drawn. All but one tab will be drawn in left to right order in the specified color, but lighter. The active tab will be drawn last in the full color and slightly taller to indicate that it is selected. Clicking the active tab has no effect but clicking any other tab will change the active tab to the clicked tab. This morph does not itself accept any events. The parent tab set will grab the mouse clicks and handle notifying the appropriate tabs that they have been activated or deactivated. There is a single selector which provides the text for the button label and affects the width of the tab. When the width changes the tab will inform its parent that it has changed and that the layout needs to be updated. The model for the text selector of course should be the client for the tab set. The button label can be a String, Text, or Morph. Texts work better than plain Strings.! !PluggableTabButtonMorph class methodsFor: 'instance creation' stamp: 'KLC 1/22/2004 14:46'! on: anObject label: getTextSelector | instance | instance _ super new. instance model: anObject. instance textSelector: getTextSelector. ^ instance ! ! !PluggableTest class methodsFor: 'example' stamp: 'nk 7/30/2004 21:50'! open "PluggableTest open" | model listView1 topView listView2 | model := self new. listView1 := PluggableListView on: model list: #musicTypeList selected: #musicType changeSelected: #musicType: menu: #musicTypeMenu: keystroke: #musicTypeKeystroke:. listView1 menuTitleSelector: #musicTypeListTitle. listView2 := PluggableListView on: model list: #artistList selected: #artist changeSelected: #artist: menu: nil keystroke: #artistKeystroke:. topView := (StandardSystemView new) label: 'Pluggable Test'; minimumSize: 300 @ 200; borderWidth: 1; addSubView: listView1; addSubView: listView2 toRightOf: listView1. topView borderWidth: 1. topView controller open! ! !PluggableTextAttribute methodsFor: 'initialization' stamp: 'ls 6/21/2001 18:06'! evalBlock: aBlock evalBlock := aBlock! ! !PluggableTextAttribute methodsFor: 'clicking' stamp: 'ls 6/21/2001 18:13'! actOnClickFor: anObject evalBlock ifNil: [ ^self ]. evalBlock numArgs = 0 ifTrue: [ evalBlock value. ^true ]. evalBlock numArgs = 1 ifTrue: [ evalBlock value: anObject. ^true ]. self error: 'evalBlock should have 0 or 1 arguments'! ! !PluggableTextAttribute commentStamp: '<historical>' prior: 0! An attribute which evaluates an arbitrary block when it is selected.! !PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'! evalBlock: aBlock ^super new evalBlock: aBlock! ! !PluggableTextController methodsFor: 'transcript' stamp: 'th 9/20/2002 11:26'! scrollIn: scrollRect "Altered from selectAndScroll so can use with null clipRect" "Scroll until the selection is in the view and then highlight it." | deltaY | deltaY _ self stopBlock top - scrollRect top. deltaY >= 0 ifTrue: [deltaY _ self stopBlock bottom - scrollRect bottom max: 0]. "check if stopIndex below bottom of scrollRect" deltaY ~= 0 ifTrue: [self scrollBy: (deltaY abs + paragraph lineGrid - 1) * deltaY sign]! ! !PluggableTextController methodsFor: 'as yet unclassified' stamp: 'dgd 9/21/2003 17:47'! accept view hasUnacceptedEdits ifFalse: [^ view flash]. view hasEditingConflicts ifTrue: [(self confirm: 'Caution!! This method may have been changed elsewhere since you started editing it here. Accept anyway?' translated) ifFalse: [^ self flash]]. (view setText: paragraph text from: self) ifTrue: [initialText _ paragraph text copy. view ifNotNil: [view hasUnacceptedEdits: false]] . ! ! !PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:37'! selectForTopFrom: start to: stop "Deselect, then select the specified characters inclusive. Be sure the selection is in view." self selectFrom: start to: stop scroll: #selectAndScrollToTop! ! !PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:37'! selectFrom: start to: stop "Deselect, then select the specified characters inclusive. Be sure the selection is in view." self selectFrom: start to: stop scroll: #selectAndScroll! ! !PluggableTextController methodsFor: 'accessing-selection' stamp: 'th 9/19/2002 18:35'! selectFrom: start to: stop scroll: scrollCommand "Deselect, then select the specified characters inclusive. Be sure the selection is in view." (start = self startIndex and: [stop + 1 = self stopIndex]) ifFalse: [view superView ifNotNil: [self deselect]. self selectInvisiblyFrom: start to: stop]. view superView ifNotNil: [self perform: scrollCommand]! ! !PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 5/22/2001 16:43'! drawOn: aCanvas "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" super drawOn: aCanvas. self wantsFrameAdornments ifTrue: [(model notNil and: [model refusesToAcceptCode]) ifTrue: "Put up feedback showing that code cannot be submitted in this state" [aCanvas frameRectangle: self innerBounds width: 2 color: Color tan] ifFalse: [self hasEditingConflicts ifTrue: [aCanvas frameRectangle: self innerBounds width: 3 color: Color red] ifFalse: [self hasUnacceptedEdits ifTrue: [model wantsDiffFeedback ifTrue: [aCanvas frameRectangle: self innerBounds width: 3 color: Color green] ifFalse: [aCanvas frameRectangle: self innerBounds width: 1 color: Color red]] ifFalse: [model wantsDiffFeedback ifTrue: [aCanvas frameRectangle: self innerBounds width: 1 color: Color green]]]]]! ! !PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 6/24/2002 16:39'! wantsFrameAdornments "Answer whether the receiver wishes to have red borders, etc., used to show editing state" "A 'long-term temporary workaround': a nonmodular, unsavory, but expedient way to get the desired effect, sorry. Clean up someday." ^ (#(annotation searchString infoViewContents) includes: getTextSelector) not! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'kfr 11/14/2004 13:20'! scrollSelectionIntoView: event "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere | selectionInterval _ textMorph editor selectionInterval. selRects _ textMorph paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest _ selRects first merge: selRects last. transform _ scroller transformFrom: self. (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" [cpHere _ transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest _ selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect _ transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [^ false]. "Would not fit, even if we tried to scroll" (delta _ selRect amountToTranslateWithin: self innerBounds) y ~= 0 ifTrue: ["Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:21'! selectAll "Tell my textMorph's editor to select all" textMorph editor selectAll! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'sw 7/24/2001 02:24'! setTextMorphToSelectAllOnMouseEnter "Tell my textMorph's editor to select all when the mouse enters" textMorph on: #mouseEnter send: #selectAll to: textMorph! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/12/2000 14:42'! keyStroke: evt "A keystroke was hit while the receiver had keyboard focus. Pass the keywtroke on to my textMorph, and and also, if I have an event handler, pass it on to that handler" textMorph keyStroke: evt. self eventHandler ifNotNil: [self eventHandler keyStroke: evt fromMorph: self]. ! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'di 11/22/2001 09:52'! mouseEnter: event super mouseEnter: event. selectionInterval ifNotNil: [textMorph editor selectInterval: selectionInterval; setEmphasisHere]. textMorph selectionChanged. event hand newKeyboardFocus: textMorph! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'sw 12/4/2001 12:42'! mouseLeave: event "The mouse has left the area of the receiver" textMorph ifNotNil: [selectionInterval _ textMorph editor selectionInterval]. super mouseLeave: event. Preferences mouseOverForKeyboardFocus ifTrue: [event hand releaseKeyboardFocus: textMorph]! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'nk 7/11/2004 19:08'! extent: newExtent bounds extent = newExtent ifTrue: [^ self]. super extent: (newExtent max: 36@16). textMorph ifNotNil: [textMorph extent: (self innerBounds width-6)@self height]. self setScrollDeltas ! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'JW 2/21/2001 22:15'! extraScrollRange ^ self height // 4! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'nk 2/14/2004 18:19'! initialize "initialize the state of the receiver" super initialize. hasUnacceptedEdits _ false. hasEditingConflicts _ false. askBeforeDiscardingEdits _ true. ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'tween 8/29/2004 20:28'! accept "Inform the model of text to be accepted, and return true if OK." | ok saveSelection saveScrollerOffset | "sps 8/13/2001 22:41: save selection and scroll info" saveSelection _ self selectionInterval copy. saveScrollerOffset _ scroller offset copy. (self canDiscardEdits and: [(self hasProperty: #alwaysAccept) not]) ifTrue: [^ self flash]. self hasEditingConflicts ifTrue: [(self confirm: 'Caution!! This method may have been changed elsewhere since you started editing it here. Accept anyway?' translated) ifFalse: [^ self flash]]. ok _ self acceptTextInModel. ok==true ifTrue: [self setText: self getText. self hasUnacceptedEdits: false. (model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo: [:aPane | model changed: #annotation]]. "sps 8/13/2001 22:41: restore selection and scroll info" ["During the step for the browser, updateCodePaneIfNeeded is called, and invariably resets the contents of the codeholding PluggableTextMorph at that time, resetting the cursor position and scroller in the process. The following line forces that update without waiting for the step, then restores the cursor and scrollbar" ok ifTrue: "(don't bother if there was an error during compile)" [(model isKindOf: CodeHolder) ifTrue: [model updateCodePaneIfNeeded]. WorldState addDeferredUIMessage: [self currentHand newKeyboardFocus: textMorph. scroller offset: saveScrollerOffset. self setScrollDeltas. self selectFrom: saveSelection first to: saveSelection last]]] on: Error do: [] ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'tween 8/29/2004 20:25'! acceptTextInModel "Inform the model that the receiver's textMorph's text should be accepted. Answer true if the model accepted ok, false otherwise" | textToAccept | textToAccept := textMorph asText. ^setTextSelector isNil or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]] ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 4/24/2001 12:24'! browseChangeSetsWithSelector "Help the user track down which change sets mention a particular selector" self handleEdit: [textMorph editor browseChangeSetsWithSelector]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'md 12/12/2003 16:21'! cancel self setText: self getText. self setSelection: self getSelection. getTextSelector == #annotation ifFalse: [(model dependents detect: [:dep | (dep isKindOf: PluggableTextMorph) and: [dep getTextSelector == #annotation]] ifNone: [nil]) ifNotNilDo: [:aPane | model changed: #annotation]]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'tk 5/1/2001 21:37'! classCommentsContainingIt self handleEdit: [textMorph editor classCommentsContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 7/31/2002 01:48'! classNamesContainingIt self handleEdit: [textMorph editor classNamesContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'vb 7/29/2001 12:45'! debugIt self handleEdit: [textMorph editor debugIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'rhi 12/6/2001 11:06'! exploreIt | result | self handleEdit: [ result _ textMorph editor evaluateSelection. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [self flash] ifFalse: [result explore]].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'ar 12/17/2001 13:00'! offerFontMenu self handleEdit: [textMorph editor changeTextFont]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'md 12/12/2003 16:21'! toggleAnnotationPaneSize | handle origin aHand siblings newHeight lf prevBottom m ht | self flag: #bob. "CRUDE HACK to enable changing the size of the annotations pane" owner ifNil: [^self]. siblings _ owner submorphs. siblings size > 3 ifTrue: [^self]. siblings size < 2 ifTrue: [^self]. aHand _ self primaryHand. origin _ aHand position. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. newHeight _ (newPoint - origin) y asInteger min: owner height - 50 max: 16. lf _ siblings last layoutFrame. lf bottomOffset: newHeight. prevBottom _ newHeight. siblings size - 1 to: 1 by: -1 do: [ :index | m _ siblings at: index. lf _ m layoutFrame. ht _ lf bottomOffset - lf topOffset. lf topOffset: prevBottom. lf bottomOffset = 0 ifFalse: [ lf bottomOffset: (prevBottom + ht). ]. prevBottom _ prevBottom + ht. ]. owner layoutChanged. ] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNilDo: [:halo | halo addHandles]. ]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor farther from this point to increase pane. Click when done.' hand: aHand. handle startStepping ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'rr 3/10/2004 09:29'! yellowButtonActivity "Called when the shifted-menu's 'more' item is chosen" | menu | (menu _ self getMenu: false) ifNotNil: ["Set up to use perform:orSendTo: for model/view dispatch" menu setInvokingView: self. menu invokeModal]! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'! getSelection "Answer the model's selection interval." getSelectionSelector isNil ifTrue: [^1 to: 0]. "null selection" ^model perform: getSelectionSelector! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:02'! getText "Retrieve the current model text" | newText | getTextSelector isNil ifTrue: [^Text new]. newText := model perform: getTextSelector. newText ifNil: [^Text new]. ^newText shallowCopy! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'tween 8/29/2004 20:43'! setText: aText scrollBar setValue: 0.0. textMorph ifNil: [textMorph _ self textMorphClass new contents: aText wrappedTo: self innerBounds width-6. textMorph setEditView: self. scroller addMorph: textMorph] ifNotNil: [textMorph newContents: aText]. self hasUnacceptedEdits: false. self setScrollDeltas.! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'sw 2/6/2001 01:24'! setTextColor: aColor "Set the color of my text to the given color" textMorph color: aColor! ! !PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:30'! scrollBarMenuButtonPressed: event "The menu button in the scrollbar was pressed; put up the menu" | menu | (menu _ self getMenu: event shiftPressed) ifNotNil: ["Set up to use perform:orSendTo: for model/view dispatch" menu setInvokingView: self. menu invokeModal]! ! !PluggableTextMorph methodsFor: 'scroll bar events' stamp: 'rr 3/10/2004 09:29'! yellowButtonActivity: shiftKeyState "Invoke the text-editing menu" | menu | (menu _ self getMenu: shiftKeyState) ifNotNil: [menu setInvokingView: self. menu invokeModal]! ! !PluggableTextMorph methodsFor: 'transcript' stamp: 'RAA 5/1/2002 18:17'! appendTextEtoy: moreText "Append the text in the model's writeStream to the editable text. " self handleEdit: [ self selectInvisiblyFrom: textMorph asText size + 1 to: textMorph asText size; replaceSelectionWith: moreText; selectFrom: textMorph asText size + 1 to: textMorph asText size; hasUnacceptedEdits: false; scrollSelectionIntoView; changed ]! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'dgd 9/21/2003 17:40'! promptForCancel "Ask if it is OK to cancel changes to text" (self confirm: 'Changes have not been saved. Is it OK to cancel those changes?' translated) ifTrue: [model clearUserEditFlag]. ! ! !PluggableTextMorph methodsFor: 'updating' stamp: 'dgd 2/22/2003 18:58'! update: aSymbol aSymbol ifNil: [^self]. aSymbol == #flash ifTrue: [^self flash]. aSymbol == getTextSelector ifTrue: [self setText: self getText. ^self setSelection: self getSelection]. aSymbol == getSelectionSelector ifTrue: [^self setSelection: self getSelection]. (aSymbol == #autoSelect and: [getSelectionSelector notNil]) ifTrue: [self handleEdit: [ParagraphEditor abandonChangeText. "no replacement!!" (textMorph editor) setSearch: model autoSelectString; againOrSame: true]]. aSymbol == #clearUserEdits ifTrue: [^self hasUnacceptedEdits: false]. aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [^self promptForCancel]. ^self]. aSymbol == #appendEntry ifTrue: [self handleEdit: [self appendEntry]. ^self refreshWorld]. aSymbol == #clearText ifTrue: [self handleEdit: [self changeText: Text new]. ^self refreshWorld]. aSymbol == #bs ifTrue: [self handleEdit: [self bsText]. ^self refreshWorld]. aSymbol == #codeChangedElsewhere ifTrue: [self hasEditingConflicts: true. ^self changed]! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'sps 3/9/2004 15:55'! hUnadjustedScrollRange "Return the width of the widest item in the list" textMorph ifNil: [ ^0 ]. textMorph isWrapped ifTrue:[ ^0 ]. ^super hUnadjustedScrollRange ! ! !PluggableTextMorph methodsFor: 'private' stamp: 'tween 8/29/2004 20:42'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForEditView! ! !PluggableTextMorphWithModel methodsFor: 'initialization' stamp: 'dgd 2/14/2003 18:25'! initialize "initialize the state of the receiver" super initialize. self on: self text: #getMyText accept: #setMyText: readSelection: nil menu: nil! ! !PluggableTextView methodsFor: 'updating' stamp: 'tk 5/23/2001 12:26'! update: aSymbol "Refer to the comment in View|update:. Do nothing if the given symbol does not match any action. " aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [self promptForCancel]. ^ self]. aSymbol == #flash ifTrue: [^ controller flash]. aSymbol == getTextSelector ifTrue: [^ self updateDisplayContents]. aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection]. aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false]. (aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue: [ParagraphEditor abandonChangeText. "no replacement!!" ^ controller setSearch: model autoSelectString; againOrSame: true]. aSymbol == #appendEntry ifTrue: [^ controller doOccluded: [controller appendEntry]]. aSymbol == #clearText ifTrue: [^ controller doOccluded: [controller changeText: Text new]]. aSymbol == #bs ifTrue: [^ controller doOccluded: [controller bsText]]. aSymbol == #codeChangedElsewhere ifTrue: [^ self hasEditingConflicts: true] ! ! !PluggableTextView methodsFor: 'controller access' stamp: 'BG 11/26/2003 16:06'! selectionInterval ^self controller selectionInterval! ! !PluggableTileScriptorMorph methodsFor: 'as yet unclassified' stamp: 'tk 9/23/2001 02:27'! syntaxMorph "Return the SyntaxMorph(MethodNode) that is inside me." | tm | ^ (tm _ self findA: TransformMorph) ifNotNil: [tm findA: SyntaxMorph]! ! !PluggableTileScriptorMorph methodsFor: 'event handling' stamp: 'tk 9/23/2001 02:28'! keyStroke: evt "A keystroke was hit while the receiver had keyboard focus. Pass the keystroke on to my syntaxMorph, and also, if I have an event handler, pass it on to that handler" | sm | (sm _ self syntaxMorph) ifNotNil: [sm keyStroke: evt]. super keyStroke: evt! ! !PluggableTileScriptorMorph methodsFor: 'updating' stamp: 'tk 9/14/2001 18:16'! update: aSymbol "Update the receiver in the manner suggested by aSymbol" aSymbol == #flash ifTrue: [^ self flash]. (aSymbol == #contents or: [aSymbol == #tiles]) ifTrue: [^ self containingWindow model installTilesForSelection]! ! !PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:58'! contentStream semaphore wait. fileStream ifNotNil: [^ fileStream]. ^ content ifNotNil: [content isString ifTrue: [self error: 'Error loading ' , self url printString] ifFalse: [content contentStream]]! ! !PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'! contents | | semaphore wait. (content isNil and:[fileStream notNil]) ifTrue:[ " pos _ fileStream position." fileStream position: 0. content _ MIMEDocument content: fileStream upToEnd. fileStream close. ]. ^content! ! !PluginHTTPDownloadRequest methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:21'! signalAbort fileStream ifNotNil: [ fileStream close]. fileStream _ nil. super signalAbort.! ! !Point methodsFor: 'arithmetic' stamp: 'TRee 6/3/2004 11:09'! reciprocal " Answer a Point with coordinates that are the reciprocals of mine. " " Method was missing from release. " " 20040301 20:50:35 TRee(Squeak3.6-5429-tree07.38) " ^ x reciprocal @ y reciprocal. ! ! !Point methodsFor: 'converting' stamp: 'wiz 11/25/2004 12:48'! asNonFractionalPoint (x isFraction or: [y isFraction]) ifTrue:[^ x asFloat @ y asFloat]! ! !Point methodsFor: 'point functions' stamp: 'FBS 1/5/2004 13:08'! bearingToPoint: anotherPoint "Return the bearing, in degrees, from the receiver to anotherPoint. Adapted from Playground, where the ultimate provenance of the algorithm was a wild earlier method of Jay Fenton's which I never checked carefully, but the thing has always seemed to work" | deltaX deltaY | deltaX := anotherPoint x - x. deltaY := anotherPoint y - y. deltaX abs < 0.001 ifTrue: [^ deltaY > 0 ifTrue: [180] ifFalse: [0]]. ^ ((deltaX >= 0 ifTrue: [90] ifFalse: [270]) - ((deltaY / deltaX) arcTan negated radiansToDegrees)) rounded ! ! !Point methodsFor: 'point functions' stamp: 'ar 5/22/2001 23:46'! insideTriangle: p1 with: p2 with: p3 "Return true if the receiver is within the triangle defined by the three coordinates. Note: This method computes the barycentric coordinates for the receiver and tests those coordinates." | p0 b0 b1 b2 b3 | p0 _ self. b0 _ ((p2 x - p1 x) * (p3 y - p1 y)) - ((p3 x - p1 x) * (p2 y - p1 y)). b0 isZero ifTrue:[^false]. "degenerate" b0 _ 1.0 / b0. b1 _ (((p2 x - p0 x) * (p3 y - p0 y)) - ((p3 x - p0 x) * (p2 y - p0 y))) * b0. b2 _ (((p3 x - p0 x) * (p1 y - p0 y)) - ((p1 x - p0 x) * (p3 y - p0 y))) * b0. b3 _ (((p1 x - p0 x) * (p2 y - p0 y)) - ((p2 x - p0 x) * (p1 y - p0 y))) * b0. b1 < 0.0 ifTrue:[^false]. b2 < 0.0 ifTrue:[^false]. b3 < 0.0 ifTrue:[^false]. ^true ! ! !Point methodsFor: 'point functions' stamp: 'ar 8/26/2001 22:15'! normalized "Optimized for speed -- ar 8/26/2001" | r | r _ ((x*x) + (y * y)) sqrt. ^(x / r) @ (y / r)! ! !Point methodsFor: 'point functions' stamp: 'ar 5/23/2001 21:29'! squaredDistanceTo: aPoint "Answer the distance between aPoint and the receiver." | delta | delta _ aPoint - self. ^delta dotProduct: delta! ! !Point methodsFor: 'printing' stamp: 'sw 9/27/2001 17:26'! basicType "Answer a symbol representing the inherent type of the receiver" ^ #Point! ! !Point methodsFor: 'private' stamp: 'tk 10/4/2001 16:16'! setR: rho degrees: degrees | radians | radians _ degrees asFloat degreesToRadians. x _ rho asFloat * radians cos. y _ rho asFloat * radians sin.! ! !Point methodsFor: 'transforming' stamp: 'ar 8/26/2001 22:14'! negated "Answer a point whose x and y coordinates are the negatives of those of the receiver. 6/6/96 sw" "Optimized for speed -- ar 8/26/2001" ^ (0 - x) @ (0 - y)! ! !Point class methodsFor: 'instance creation' stamp: 'tk 10/4/2001 16:17'! r: rho degrees: degrees "Answer an instance of me with polar coordinates rho and theta." ^self new setR: rho degrees: degrees! ! !PointArray methodsFor: 'converting' stamp: 'NS 5/30/2001 20:54'! asPointArray ^ self! ! !PointTest methodsFor: 'testing - testing' stamp: 'FBS 1/5/2004 13:08'! testBearingToPoint self assert: (0@0 bearingToPoint: 0@0) = 0. self assert: (0@0 bearingToPoint: 0@-1) = 0. self assert: (0@0 bearingToPoint: 1@0) = 90. self assert: (0@0 bearingToPoint: 0@1) = 180. self assert: (0@0 bearingToPoint: -1@0) = 270. self assert: (0@0 bearingToPoint: 1@1) = 135. self assert: (0@0 bearingToPoint: 0.01@0) = 90. self assert: (0@0 bearingToPoint: -2@-3) = 326. self assert: (0@0 bearingToPoint: -0@0) = 0. self assert: (-2@-3 bearingToPoint: 0@0) = 146.! ! !PointTest methodsFor: 'testing - testing' stamp: 'md 4/15/2003 21:38'! testIsZero self assert: (0@0) isZero. self deny: (0@1) isZero. self deny: (1@0) isZero. self deny: (1@1) isZero.! ! !PointTest commentStamp: '<historical>' prior: 0! This is the unit test for the class Point. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !PointerExplorer methodsFor: 'accessing' stamp: 'ab 8/22/2003 18:51'! getList ^Array with: (PointerExplorerWrapper with: rootObject name: rootObject identityHash asString model: self) ! ! !PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0! A variant on the ObjectExlorer that works "backwards": like the ObjectExplorer, it shows a tree of objects, but expanding a node won't show the objects which that node references, but rather the objects that reference that node. Its main use is to track down memory leaks: if you want to know why a particular object is still alive, open a PointerExplorer on it and drill down until you find the root object that's referencing it. For example, find all the references to the symbol #zot with: PointerExplorer new openExplorerFor: #zot For the "name" of the object, the PointerExplorer shows each object's identityHash, to allow the user to identify when two similar objects are identical and notice cycles.! !PointerExplorerWrapper methodsFor: 'testing' stamp: 'ab 8/22/2003 18:39'! hasContents ^true! ! !PointerExplorerWrapper methodsFor: 'accessing' stamp: 'md 9/29/2004 22:42'! contents | objects | objects _ PointerFinder pointersTo: item except: (Array with: self with: model). ^(objects reject: [:ea | ea class = self class]) collect: [:ea| self class with: ea name: ea identityHash asString model: item]! ! !PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0! A subclass of ObjectExplorerWrapper for use with PointerExplorer. #contents is overridden to work backwards: it returns wrappers for the objects pointing to item rather than for the objects that item points to.! !PointerFinder methodsFor: 'morphic ui' stamp: 'nb 6/17/2003 12:25'! inspectObject pointerListIndex = 0 ifTrue: [^ Beeper beep]. (objectList at: pointerListIndex) inspect! ! !PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:49'! pointersTo: anObject "Find all occurrences in the system of pointers to the argument anObject." "(PointerFinder pointersTo: Browser) inspect." ^ self pointersTo: anObject except: #() ! ! !PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:47'! pointersTo: anObject except: objectsToExclude "Find all occurrences in the system of pointers to the argument anObject. Remove objects in the exclusion list from the results." | results anObj | Smalltalk garbageCollect. "big collection shouldn't grow, so it's contents array is always the same" results _ OrderedCollection new: 1000. "allObjectsDo: is expanded inline to keep spurious method and block contexts out of the results" anObj _ self someObject. [0 == anObj] whileFalse: [ anObj isInMemory ifTrue: [ (anObj pointsTo: anObject) ifTrue: [ "exclude the results collector and contexts in call chain" ((anObj ~~ results collector) and: [(anObj ~~ objectsToExclude) and: [(anObj ~~ thisContext) and: [(anObj ~~ thisContext sender) and: [anObj ~~ thisContext sender sender]]]]) ifTrue: [ results add: anObj ]. ]]. anObj _ anObj nextObject. ]. objectsToExclude do: [ :obj | results removeAllSuchThat: [ :el | el == obj]]. ^ results asArray ! ! !PointerFinder class methodsFor: 'utilities' stamp: 'sd 9/24/2004 20:48'! pointersToItem: index of: anArray "Find all occurrences in the system of pointers to the given element of the given array. This is useful for tracing up a pointer chain from an inspector on the results of a previous call of pointersTo:. To find out who points to the second element of the results, one would evaluate: PointerFinder pointersToItem: 2 of: self in the inspector." ^ self pointersTo: (anArray at: index) except: (Array with: anArray)! ! !PolygonMorph methodsFor: 'access' stamp: 'aoy 2/15/2003 20:51'! borderColor: aColor super borderColor: aColor. (borderColor isColor and: [borderColor isTranslucentColor]) == (aColor isColor and: [aColor isTranslucentColor]) ifFalse: ["Need to recompute fillForm and borderForm if translucency of border changes." self releaseCachedState]! ! !PolygonMorph methodsFor: 'access' stamp: 'dgd 12/11/2003 13:14'! openOrClosePhrase | curveName | curveName := (self isCurve ifTrue: ['curve'] ifFalse: ['polygon']) translated. ^ closed ifTrue: ['make open {1}' translated format: {curveName}] ifFalse: ['make closed {1}' translated format: {curveName}]! ! !PolygonMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:23'! borderWidth: anInteger borderColor ifNil: [borderColor _ Color black]. borderWidth _ anInteger max: 0. self computeBounds! ! !PolygonMorph methodsFor: 'dashes' stamp: 'dgd 2/22/2003 18:55'! borderDashOffset borderDashSpec size < 4 ifTrue: [^0.0]. ^(borderDashSpec fourth) asFloat! ! !PolygonMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 18:56'! drawArrowOn: aCanvas at: endPoint from: priorPoint "Draw a triangle oriented along the line from priorPoint to endPoint. Answer the wingBase." | pts spec wingBase | pts := self arrowBoundsAt: endPoint from: priorPoint. wingBase := pts size = 4 ifTrue: [pts third] ifFalse: [(pts copyFrom: 2 to: 3) average]. spec := self valueOfProperty: #arrowSpec ifAbsent: [5 @ 4]. spec x sign = spec y sign ifTrue: [aCanvas drawPolygon: pts fillStyle: borderColor] ifFalse: [aCanvas drawPolygon: pts fillStyle: Color transparent borderWidth: (borderWidth + 1) // 2 borderColor: borderColor]. ^wingBase! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawBorderOn: aCanvas self drawClippedBorderOn: aCanvas usingEnds: (Array with: vertices first with: vertices last)! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 14:53'! drawBorderOn: aCanvas usingEnds: anArray "Display my border on the canvas." "NOTE: Much of this code is also copied in drawDashedBorderOn: (should be factored)" | bigClipRect p1i p2i style | borderDashSpec ifNotNil: [^ self drawDashedBorderOn: aCanvas usingEnds: anArray]. style _ self borderStyle. bigClipRect _ aCanvas clipRect expandBy: self borderWidth + 1 // 2. self lineSegmentsDo: [:p1 :p2 | p1i _ p1 asIntegerPoint. p2i _ p2 asIntegerPoint. (arrows ~= #none and: [closed not]) ifTrue: ["Shorten line ends so as not to interfere with tip of arrow." ((arrows == #back or: [arrows == #both]) and: [p1 = vertices first]) ifTrue: [p1i _ anArray first asIntegerPoint]. ((arrows == #forward or: [arrows == #both]) and: [p2 = vertices last]) ifTrue: [p2i _ anArray last asIntegerPoint]]. (closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:" ((p1i min: p2i) max: bigClipRect origin) <= ((p1i max: p2i) min: bigClipRect corner)]) ifTrue: [style drawLineFrom: p1i to: p2i on: aCanvas]]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawClippedBorderOn: aCanvas usingEnds: anArray aCanvas clipBy: self bounds during:[:cc| self drawBorderOn: cc usingEnds: anArray].! ! !PolygonMorph methodsFor: 'drawing' stamp: 'dgd 2/22/2003 14:17'! drawDashedBorderOn: aCanvas usingEnds: anArray "Display my border on the canvas. NOTE: mostly copied from drawBorderOn:" | lineColor bevel topLeftColor bottomRightColor bigClipRect p1i p2i segmentOffset | (borderColor isNil or: [borderColor isColor and: [borderColor isTransparent]]) ifTrue: [^self]. lineColor := borderColor. bevel := false. "Border colors for bevelled effects depend on CW ordering of vertices" borderColor == #raised ifTrue: [topLeftColor := color lighter. bottomRightColor := color darker. bevel := true]. borderColor == #inset ifTrue: [topLeftColor := owner colorForInsets darker. bottomRightColor := owner colorForInsets lighter. bevel := true]. bigClipRect := aCanvas clipRect expandBy: (self borderWidth + 1) // 2. segmentOffset := self borderDashOffset. self lineSegmentsDo: [:p1 :p2 | p1i := p1 asIntegerPoint. p2i := p2 asIntegerPoint. (arrows ~= #none and: [closed not]) ifTrue: ["Shorten line ends so as not to interfere with tip of arrow." ((arrows == #back or: [arrows == #both]) and: [p1 = vertices first]) ifTrue: [p1i := anArray first asIntegerPoint]. ((arrows == #forward or: [arrows == #both]) and: [p2 = vertices last]) ifTrue: [p2i := anArray last asIntegerPoint]]. (closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:" ((p1i min: p2i) max: bigClipRect origin) <= ((p1i max: p2i) min: bigClipRect corner)]) ifTrue: [bevel ifTrue: [lineColor := (p1i quadrantOf: p2i) > 2 ifTrue: [topLeftColor] ifFalse: [bottomRightColor]]. segmentOffset := aCanvas line: p1i to: p2i width: borderWidth color: lineColor dashLength: borderDashSpec first secondColor: borderDashSpec third secondDashLength: borderDashSpec second startingOffset: segmentOffset]]! ! !PolygonMorph methodsFor: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." | array | vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. closed ifTrue: [aCanvas drawPolygon: self getVertices fillStyle: self fillStyle. aCanvas isShadowDrawing ifTrue: [^ self]]. array _ self drawArrowsOn: aCanvas. self drawClippedBorderOn: aCanvas usingEnds: array. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:32'! addHandles | handle newVert tri | self removeHandles. handles _ OrderedCollection new. tri _ Array with: 0@-4 with: 4@3 with: -3@3. vertices withIndexDo: [:vertPt :vertIndex | handle _ EllipseMorph newBounds: (Rectangle center: vertPt extent: 8@8) color: Color yellow. handle on: #mouseMove send: #dragVertex:event:fromHandle: to: self withValue: vertIndex. handle on: #mouseUp send: #dropVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: handle. handles addLast: handle. (closed or: [vertIndex < vertices size]) ifTrue: [newVert _ PolygonMorph vertices: (tri collect: [:p | p + (vertPt + (vertices atWrap: vertIndex+1) // 2)]) color: Color green borderWidth: 1 borderColor: Color black. newVert on: #mouseDown send: #newVertex:event:fromHandle: to: self withValue: vertIndex. self addMorph: newVert. handles addLast: newVert]]. smoothCurve ifTrue: [self updateHandles; layoutChanged]. self changed! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:30'! dragVertex: ix event: evt fromHandle: handle | p | p _ self isCurve ifTrue: [evt cursorPoint] ifFalse: [self griddedPoint: evt cursorPoint]. handle position: p - (handle extent//2). self verticesAt: ix put: p. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! dragVertex: arg1 fromHandle: arg2 vertIndex: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self dragVertex: arg1 event: arg2 fromHandle: arg3! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:31'! dropVertex: ix event: evt fromHandle: handle | p | p _ vertices at: ix. (((vertices atWrap: ix-1) dist: p) < 3 or: [((vertices atWrap: ix+1) dist: p) < 3]) ifTrue: ["Drag a vertex onto its neighbor means delete" self setVertices: (vertices copyReplaceFrom: ix to: ix with: Array new)]. evt shiftPressed ifTrue: [self removeHandles] ifFalse: [self addHandles "remove then add to recreate"]! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! dropVertex: arg1 fromHandle: arg2 vertIndex: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self dropVertex: arg1 event: arg2 fromHandle: arg3! ! !PolygonMorph methodsFor: 'editing' stamp: 'sw 9/25/2002 01:16'! newVertex: ix event: evt fromHandle: handle "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events." | pt | (self hasProperty: #noNewVertices) ifFalse: [pt _ evt cursorPoint. self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)). evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1)] ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/18/2001 17:28'! newVertex: arg1 fromHandle: arg2 afterVert: arg3 "Reorder the arguments for existing event handlers" (arg3 isMorph and:[arg3 eventHandler notNil]) ifTrue:[arg3 eventHandler fixReversedValueMessages]. ^self newVertex: arg1 event: arg2 fromHandle: arg3! ! !PolygonMorph methodsFor: 'event handling' stamp: 'nk 8/8/2001 12:13'! mouseDown: evt ^ evt shiftPressed ifTrue: [((owner isKindOf: PolygonMorph) and: [owner includesHandle: self]) ifTrue: ["Prevent insertion handles from getting edited" ^ super mouseDown: evt]. self toggleHandles. handles ifNil: [^ self]. vertices withIndexDo: "Check for click-to-drag at handle site" [:vertPt :vertIndex | ((handles at: vertIndex*2-1 ifAbsent: [ ^self ]) containsPoint: evt cursorPoint) ifTrue: ["If clicked near a vertex, jump into drag-vertex action" evt hand newMouseFocus: (handles at: vertIndex*2-1)]]] ifFalse: [super mouseDown: evt]! ! !PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 14:14'! closestPointTo: aPoint | curvePoint closestPoint dist minDist | closestPoint := minDist := nil. self lineSegmentsDo: [:p1 :p2 | curvePoint := aPoint nearestPointOnLineFrom: p1 to: p2. dist := curvePoint dist: aPoint. (closestPoint isNil or: [dist < minDist]) ifTrue: [closestPoint := curvePoint. minDist := dist]]. ^closestPoint! ! !PolygonMorph methodsFor: 'geometry' stamp: 'edc 3/20/2002 14:24'! flipHAroundX: centerX "Flip me horizontally around the center. If centerX is nil, compute my center of gravity." | cent | cent _ centerX ifNil: [bounds center x "cent _ 0. vertices do: [:each | cent _ cent + each x]. cent asFloat / vertices size"] "average is the center" ifNotNil: [centerX]. self setVertices: (vertices collect: [:vv | ((vv x - cent) * -1 + cent) @ vv y]) reversed.! ! !PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'! flipVAroundY: centerY "Flip me vertically around the center. If centerY is nil, compute my center of gravity." | cent | cent _ centerY ifNil: [bounds center y "cent _ 0. vertices do: [:each | cent _ cent + each y]. cent asFloat / vertices size"] "average is the center" ifNotNil: [centerY]. self setVertices: (vertices collect: [:vv | vv x @ ((vv y - cent) * -1 + cent)]) reversed.! ! !PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:56'! merge: aPolygon "Expand myself to enclose the other polygon. (Later merge overlapping or disjoint in a smart way.) For now, the two polygons must share at least two vertices. Shared vertices must come one after the other in each polygon. Polygons must not overlap." | shared mv vv hv xx | shared := vertices select: [:mine | aPolygon vertices includes: mine]. shared size < 2 ifTrue: [^nil]. "not sharing a segment" mv := vertices asOrderedCollection. [shared includes: mv first] whileFalse: ["rotate them" vv := mv removeFirst. mv addLast: vv]. hv := aPolygon vertices asOrderedCollection. [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first" vv := hv removeFirst. hv addLast: vv]. [shared size > 2] whileTrue: [shared := shared asOrderedCollection. (self mergeDropThird: mv in: hv from: shared) ifNil: [^nil]]. "works by side effect on the lists" (mv second) = hv last ifTrue: [mv removeFirst; removeFirst. ^self setVertices: (hv , mv) asArray]. (hv second) = mv last ifTrue: [hv removeFirst; removeFirst. ^self setVertices: (mv , hv) asArray]. (mv second) = (hv second) ifTrue: [hv removeFirst. mv remove: (mv second). xx := mv removeFirst. ^self setVertices: (hv , (Array with: xx) , mv reversed) asArray]. mv last = hv last ifTrue: [mv removeLast. hv removeFirst. ^self setVertices: (mv , hv reversed) asArray]. ^nil! ! !PolygonMorph methodsFor: 'geometry' stamp: 'dgd 2/22/2003 18:57'! mergeDropThird: mv in: hv from: shared "We are merging two polygons. In this case, they have at least three identical shared vertices. Make sure they are sequential in each, and drop the middle one from vertex lists mv, hv, and shared. First vertices on lists are identical already." "know (mv first = hv first)" | mdrop vv | (shared includes: (mv at: mv size - 2)) ifTrue: [(shared includes: mv last) ifTrue: [mdrop := mv last]] ifFalse: [(shared includes: mv last) ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv first]]]. (shared includes: (mv third)) ifTrue: [(shared includes: mv second) ifTrue: [mdrop := mv second]]. mdrop ifNil: [^nil]. mv remove: mdrop. hv remove: mdrop. shared remove: mdrop. [shared includes: mv first] whileFalse: ["rotate them" vv := mv removeFirst. mv addLast: vv]. [mv first = hv first] whileFalse: ["rotate him until same shared vertex is first" vv := hv removeFirst. hv addLast: vv]! ! !PolygonMorph methodsFor: 'geometry eToy' stamp: 'nk 9/4/2004 11:57'! scale: scaleFactor | flex center ratio | ratio := self scaleFactor / scaleFactor. self borderWidth: ((self borderWidth / ratio) rounded max: 0). center := self referencePosition. flex := (MorphicTransform offset: center negated) withScale: ratio. self setVertices: (vertices collect: [:v | (flex transform: v) - flex offset]). super scale: scaleFactor.! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:35'! defaultBorderColor "answer the default border color/fill style for the receiver" ^ Color r: 0.0 g: 0.419 b: 0.935! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:10'! initialize "initialize the state of the receiver" super initialize. "" vertices _ Array with: 5 @ 0 with: 20 @ 10 with: 0 @ 20. closed _ true. smoothCurve _ false. arrows _ #none. self computeBounds! ! !PolygonMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:09'! vertices: verts color: aColor borderWidth: borderWidthInteger borderColor: anotherColor super initialize. "" vertices _ verts. color _ aColor. borderWidth _ borderWidthInteger. borderColor _ anotherColor. closed _ vertices size > 2. arrows _ #none. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 12:48'! addCustomMenuItems: aMenu hand: aHandMorph | lineName | super addCustomMenuItems: aMenu hand: aHandMorph. aMenu addUpdating: #handlesShowingPhrase target: self action: #showOrHideHandles. vertices size > 2 ifTrue: [aMenu addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed. lineName _ (closed ifTrue: ['outline'] ifFalse: ['line']) translated. self isCurve ifTrue: [aMenu add: ('make segmented {1}' translated format: {lineName translated}) action: #toggleSmoothing] ifFalse: [aMenu add: ('make smooth {1}' translated format: {lineName translated}) action: #toggleSmoothing]]. aMenu add: 'specify dashed line' translated action: #specifyDashedLine. self isOpen ifTrue: [aMenu addLine. aMenu addWithLabel: '---' enablement: [self isOpen and: [arrows ~~ #none]] action: #makeNoArrows. aMenu addWithLabel: '-->' enablement: [self isOpen and: [arrows ~~ #forward]] action: #makeForwardArrow. aMenu addWithLabel: '<--' enablement: [self isOpen and: [arrows ~~ #back]] action: #makeBackArrow. aMenu addWithLabel: '<->' enablement: [self isOpen and: [arrows ~~ #both]] action: #makeBothArrows. aMenu add: 'customize arrows' translated action: #customizeArrows:. (self hasProperty: #arrowSpec) ifTrue: [aMenu add: 'standard arrows' translated action: #standardArrows]].! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 19:23'! arrowLength: aLength "Assumes that I have exactly two vertices" | theta horizontalOffset verticalOffset newTip delta | delta _ vertices second - vertices first. theta _ delta theta. horizontalOffset _ aLength * (theta cos). verticalOffset _ aLength * (theta sin). newTip _ vertices first + (horizontalOffset @ verticalOffset). self verticesAt: 2 put: newTip! ! !PolygonMorph methodsFor: 'menu' stamp: 'md 12/12/2003 16:22'! customizeArrows: evt | handle origin aHand | aHand _ evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin _ aHand position. handle _ HandleMorph new forEachPointDo: [:newPoint | handle removeAllMorphs. handle addMorph: (LineMorph from: origin to: newPoint color: Color black width: 1). self arrowSpec: (newPoint - origin) / 5.0] lastPointDo: [:newPoint | handle deleteBalloon. self halo ifNotNilDo: [:halo | halo addHandles].]. aHand attachMorph: handle. handle setProperty: #helpAtCenter toValue: true. handle showBalloon: 'Move cursor left and right to change arrow length and style. Move it up and down to change width. Click when done.' hand: evt hand. handle startStepping! ! !PolygonMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:57'! handlesShowingPhrase ^ (self showingHandles ifTrue: ['hide handles'] ifFalse: ['show handles']) translated! ! !PolygonMorph methodsFor: 'menu' stamp: 'yo 3/14/2005 12:54'! specifyDashedLine | executableSpec newSpec | executableSpec _ FillInTheBlank request: 'Enter a dash specification as { major dash length. minor dash length. minor dash color } The major dash will have the normal border color. A blank response will remove the dash specification. [Note: You may give 5 items as, eg, {10. 5. Color white. 0. 3} where the 4th ityem is zero, and the 5th is the number of pixels by which the dashes will move in each step of animation]' translated initialAnswer: '{ 10. 5. Color red }'. executableSpec isEmpty ifTrue: [^ self stopStepping; dashedBorder: nil]. newSpec _ [Compiler evaluate: executableSpec] ifError: [^ self stopStepping; dashedBorder: nil]. newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse: [^ self stopStepping; dashedBorder: nil]. newSpec size = 3 ifTrue: [^ self stopStepping; dashedBorder: newSpec]. (newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue: [^ self dashedBorder: newSpec; startStepping]. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:06'! unrotatedLength "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size == 2 ifTrue: [^ (vertices second - vertices first) r]. ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:54'! unrotatedLength: aLength "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size == 2 ifTrue: [^ self arrowLength: aLength]. self setVertices: ((((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) height: aLength) rotationDegrees: 0) vertices! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:17'! unrotatedWidth "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" vertices size == 2 ifTrue: [^ self borderWidth]. ^ ((PolygonMorph new setVertices: vertices) rotationDegrees: self rotationDegrees negated) width! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 9/24/2002 18:18'! unrotatedWidth: aWidth "If the receiver bears rotation without a transformation morph, answer what its length in the direction it is headed is" self borderWidth: aWidth! ! !PolygonMorph methodsFor: 'rotate scale and flex' stamp: 'di 11/28/2001 18:23'! addFlexShellIfNecessary "When scaling or rotating from a halo, I can do this without a flex shell" ^ self ! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:14'! coefficients "Compute an array for the coefficients. This is copied from Flegal's old code in the Spline class." | length extras verts coefficients | curveState ifNotNil: [^curveState first]. verts := closed ifTrue: [vertices copyWith: vertices first] ifFalse: [vertices]. length := verts size. extras := 0. coefficients := Array new: 8. 1 to: 8 do: [:i | coefficients at: i put: (Array new: length + extras)]. 1 to: 5 by: 4 do: [:k | 1 to: length do: [:i | (coefficients at: k) at: i put: (k = 1 ifTrue: [(verts at: i) x asFloat] ifFalse: [(verts at: i) y asFloat])]. 1 to: extras do: [:i | (coefficients at: k) at: length + i put: ((coefficients at: k) at: i + 1)]. self derivs: (coefficients at: k) first: (coefficients at: k + 1) second: (coefficients at: k + 2) third: (coefficients at: k + 3)]. extras > 0 ifTrue: [1 to: 8 do: [:i | coefficients at: i put: ((coefficients at: i) copyFrom: 2 to: length + 1)]]. curveState := { coefficients. nil. nil}. self computeNextToEndPoints. ^coefficients! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:15'! computeNextToEndPoints | pointAfterFirst pointBeforeLast | pointAfterFirst := nil. self lineSegmentsDo: [:p1 :p2 | pointAfterFirst isNil ifTrue: [pointAfterFirst := p2 asIntegerPoint]. pointBeforeLast := p1 asIntegerPoint]. curveState at: 2 put: pointAfterFirst. curveState at: 3 put: pointBeforeLast! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:16'! derivs: a first: point1 second: point2 third: point3 "Compute the first, second and third derivitives (in coeffs) from the Points in this Path (coeffs at: 1 and coeffs at: 5)." | len v anArray | len := a size. len < 2 ifTrue: [^self]. len > 2 ifTrue: [v := Array new: len. v at: 1 put: 4.0. anArray := Array new: len. anArray at: 1 put: 6.0 * (a first - (a second * 2.0) + (a third)). 2 to: len - 2 do: [:i | v at: i put: 4.0 - (1.0 / (v at: i - 1)). anArray at: i put: 6.0 * ((a at: i) - ((a at: i + 1) * 2.0) + (a at: i + 2)) - ((anArray at: i - 1) / (v at: i - 1))]. point2 at: len - 1 put: (anArray at: len - 2) / (v at: len - 2). len - 2 to: 2 by: 0 - 1 do: [:i | point2 at: i put: ((anArray at: i - 1) - (point2 at: i + 1)) / (v at: i - 1)]]. point2 at: 1 put: (point2 at: len put: 0.0). 1 to: len - 1 do: [:i | point1 at: i put: (a at: i + 1) - (a at: i) - (((point2 at: i) * 2.0 + (point2 at: i + 1)) / 6.0). point3 at: i put: (point2 at: i + 1) - (point2 at: i)]! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 14:21'! lineSegmentsDo: endPointsBlock "Emit a sequence of segment endpoints into endPointsBlock." | n t x y x1 x2 x3 y1 y2 y3 beginPoint endPoint cs | smoothCurve ifFalse: [beginPoint := nil. vertices do: [:vert | beginPoint ifNotNil: [endPointsBlock value: beginPoint value: vert]. beginPoint := vert]. (closed or: [vertices size = 1]) ifTrue: [endPointsBlock value: beginPoint value: vertices first]. ^self]. "For curves we include all the interpolated sub segments." vertices size < 1 ifTrue: [^self]. cs := self coefficients. beginPoint := (x := cs first first) @ (y := cs fifth first). 1 to: cs first size - 1 do: [:i | "taylor series coefficients" x1 := cs second at: i. y1 := cs sixth at: i. x2 := (cs third at: i) / 2.0. y2 := (cs seventh at: i) / 2.0. x3 := (cs fourth at: i) / 6.0. y3 := ((cs eighth) at: i) / 6.0. "guess n" n := 5 max: (((x2 abs + y2 abs) * 2.0 + (cs third at: i + 1) abs + (cs seventh at: i + 1) abs) / 100.0) rounded. 1 to: n - 1 do: [:j | t := j asFloat / n. endPoint := (((x3 * t + x2) * t + x1) * t + x) @ (((y3 * t + y2) * t + y1) * t + y). endPointsBlock value: beginPoint value: endPoint. beginPoint := endPoint]. endPoint := (x := cs first at: i + 1) @ (y := cs fifth at: i + 1). endPointsBlock value: beginPoint value: endPoint. beginPoint := endPoint]! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 18:57'! nextToFirstPoint "For arrow direction" smoothCurve ifTrue: [curveState ifNil: [self coefficients]. ^curveState second] ifFalse: [^vertices second]! ! !PolygonMorph methodsFor: 'smoothing' stamp: 'dgd 2/22/2003 18:58'! nextToLastPoint "For arrow direction" smoothCurve ifTrue: [curveState ifNil: [self coefficients]. ^curveState third] ifFalse: [^vertices at: vertices size - 1]! ! !PolygonMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 18:58'! step borderDashSpec ifNil: [^super step]. borderDashSpec size < 5 ifTrue: [^super step]. "Only for dashed lines with creep" borderDashSpec at: 4 put: (borderDashSpec fourth) + borderDashSpec fifth. self changed. ^super step! ! !PolygonMorph methodsFor: 'testing' stamp: 'dgd 2/22/2003 18:58'! wantsSteps super wantsSteps ifTrue: [^true]. "For crawling ants effect of dashed line." borderDashSpec ifNil: [^false]. ^borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! ! !PolygonMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 18:56'! computeArrowFormAt: endPoint from: priorPoint "Compute a triangle oriented along the line from priorPoint to endPoint. Then draw those lines in a form and return that form, with appropriate offset" | p1 pts box arrowForm bb origin | pts := self arrowBoundsAt: endPoint from: priorPoint. box := ((pts first rect: pts last) encompass: (pts second)) expandBy: 1. arrowForm := Form extent: box extent asIntegerPoint. bb := (BitBlt current toForm: arrowForm) sourceForm: nil; fillColor: Color black; combinationRule: Form over; width: 1; height: 1. origin := box topLeft. p1 := pts last - origin. pts do: [:p | bb drawFrom: p1 to: p - origin. p1 := p - origin]. arrowForm convexShapeFill: Color black. ^arrowForm offset: box topLeft! ! !PolygonMorph methodsFor: 'private' stamp: 'ar 2/6/2002 12:18'! computeBounds | oldBounds delta excludeHandles | vertices ifNil: [^ self]. self changed. oldBounds _ bounds. self releaseCachedState. bounds _ self curveBounds truncated. self arrowForms do: [:f | bounds _ bounds merge: (f offset extent: f extent)]. handles ifNotNil: [self updateHandles]. "since we are directly updating bounds, see if any ordinary submorphs exist and move them accordingly" (oldBounds notNil and: [(delta _ bounds origin - oldBounds origin) ~= (0@0)]) ifTrue: [ excludeHandles _ IdentitySet new. handles ifNotNil: [excludeHandles addAll: handles]. self submorphsDo: [ :each | (excludeHandles includes: each) ifFalse: [ each position: each position + delta ]. ]. ]. self layoutChanged. self changed. ! ! !PolygonMorph methodsFor: 'private' stamp: 'dgd 2/22/2003 14:15'! curveBounds | curveBounds pointAfterFirst pointBeforeLast | smoothCurve ifFalse: [^(Rectangle encompassing: vertices) expandBy: (borderWidth + 1) // 2]. "Compute the bounds from actual curve traversal, with leeway for borderWidth. Also note the next-to-first and next-to-last points for arrow directions." curveState := nil. "Force recomputation" curveBounds := vertices first corner: vertices last. pointAfterFirst := nil. self lineSegmentsDo: [:p1 :p2 | pointAfterFirst isNil ifTrue: [pointAfterFirst := p2 asIntegerPoint. curveBounds := curveBounds encompass: p1 asIntegerPoint]. curveBounds := curveBounds encompass: p2 asIntegerPoint. pointBeforeLast := p1 asIntegerPoint]. curveState at: 2 put: pointAfterFirst. curveState at: 3 put: pointBeforeLast. ^curveBounds expandBy: (borderWidth + 1) // 2! ! !PolygonMorph methodsFor: 'private' stamp: 'md 12/12/2003 16:22'! privateMoveBy: delta super privateMoveBy: delta. vertices _ vertices collect: [:p | p + delta]. self arrowForms do: [:f | f offset: f offset + delta]. curveState _ nil. "Force recomputation" (self valueOfProperty: #referencePosition) ifNotNilDo: [:oldPos | self setProperty: #referencePosition toValue: oldPos + delta]! ! !PolygonMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'ar 11/26/2001 23:15'! drawPostscriptOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." | array | vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. array _ self drawArrowsOn: aCanvas. closed ifTrue: [aCanvas drawPolygon: self getVertices color: self color borderWidth: self borderWidth borderColor: self borderColor] ifFalse: [self drawClippedBorderOn: aCanvas usingEnds: array]. ! ! !PolygonMorph methodsFor: '*connectors-testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^closed not! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'sw 10/3/2002 02:19'! arrowPrototype "Answer an instance of the receiver that will serve as a prototypical arrow" | aa | aa _ self new. aa vertices: (Array with: 0@0 with: 40@40) color: Color black borderWidth: 2 borderColor: Color black. aa setProperty: #noNewVertices toValue: true. aa makeForwardArrow. "is already open" aa computeBounds. ^ aa! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 03:56'! fromHand: hand "Let the user draw a polygon, clicking at each vertex, and ending by clicking within 5 of the first point..." | p1 poly oldVerts pN opposite | Cursor crossHair showWhile: [[Sensor anyButtonPressed] whileFalse: [self currentWorld displayWorldSafely; runStepMethods]. p1 _ Sensor cursorPoint]. opposite _ (Display colorAt: p1) negated. opposite = Color transparent ifTrue: [opposite _ Color red]. (poly _ LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. oldVerts _ {p1}. self currentWorld displayWorldSafely; runStepMethods. [true] whileTrue: [[Sensor anyButtonPressed] whileTrue: [pN _ Sensor cursorPoint. poly setVertices: (oldVerts copyWith: pN). self currentWorld displayWorldSafely; runStepMethods]. (oldVerts size > 1 and: [(pN dist: p1) < 5]) ifTrue: [hand position: Sensor cursorPoint. "Done -- update hand pos" ^ (poly setVertices: (poly vertices copyWith: p1)) delete]. oldVerts _ poly vertices. [Sensor anyButtonPressed] whileFalse: [pN _ Sensor cursorPoint. poly setVertices: (oldVerts copyWith: pN). self currentWorld displayWorldSafely; runStepMethods]]. ! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'di 10/18/2001 04:42'! fromHandFreehand: hand "Let the user draw a polygon, holding the mouse down, and ending by clicking within 5 of the first point..." | p1 poly pN opposite | Cursor crossHair showWhile: [[Sensor anyButtonPressed] whileFalse: [self currentWorld displayWorldSafely; runStepMethods]. p1 _ Sensor cursorPoint]. opposite _ (Display colorAt: p1) negated. opposite = Color transparent ifTrue: [opposite _ Color red]. (poly _ LineMorph from: p1 to: p1 color: opposite width: 2) openInWorld. self currentWorld displayWorldSafely; runStepMethods. [Sensor anyButtonPressed] whileTrue: [pN _ Sensor cursorPoint. (pN dist: poly vertices last) > 3 ifTrue: [poly setVertices: (poly vertices copyWith: pN). self currentWorld displayWorldSafely; runStepMethods]]. hand position: Sensor cursorPoint. "Done -- update hand pos" ^ (poly setVertices: (poly vertices copyWith: p1)) delete! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'nk 8/23/2004 18:12'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'Arrow' categoryList: #('Basic' 'Graphics') documentation: 'A line with an arrowhead. Shift-click to get handles and move the ends.' globalReceiverSymbol: #PolygonMorph nativitySelector: #arrowPrototype} ! ! !PolygonMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:12'! descriptionForPartsBin ^ self partName: 'Polygon' categories: #('Graphics' 'Basic') documentation: 'A series of connected line segments, which may be a closed solid, or a zig-zag line. Shift-click to get handles and move the points.'! ! !PolygonMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:03'! initialize self registerInFlapsRegistry. ! ! !PolygonMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:10'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(PolygonMorph authoringPrototype 'Polygon' 'A straight-sided figure with any number of sides') forFlapNamed: 'Supplies'.]! ! !PolygonMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !PopUpChoiceMorph methodsFor: 'event handling' stamp: 'dgd 2/21/2003 22:50'! mouseDown: evt | items menu selectedItem | (target isNil or: [getItemsSelector isNil]) ifTrue: [^self]. items := target perform: getItemsSelector withArguments: getItemsArgs. menu := CustomMenu new. items do: [:item | menu add: item action: item]. selectedItem := menu startUp. selectedItem ifNil: [^self]. self contentsClipped: selectedItem. "Client can override this if necess" actionSelector ifNotNil: [target perform: actionSelector withArguments: (arguments copyWith: selectedItem)]! ! !PopUpChoiceMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 20:44'! initialize "initialize the state of the receiver" super initialize. "" self contents: 'PopUpChoice of Colors'. target _ Color. actionSelector _ nil. arguments _ EmptyArray. getItemsSelector _ #colorNames. getItemsArgs _ EmptyArray! ! !PopUpMenu methodsFor: 'accessing' stamp: 'sw 3/12/2002 21:37'! startUpLeftFlush "Build and invoke this menu with no initial selection. By Jerry Archibald, 4/01. If in MVC, align menus items with the left margin. Answer the selection associated with the menu item chosen by the user or nil if none is chosen. The mechanism for getting left-flush appearance in mvc leaves a tiny possibility for misadventure: if the user, in mvc, puts up the jump-to-project menu, then hits cmd period while it is up, then puts up a second jump-to-project menu before dismissing or proceeding through the debugger, it's possible for mvc popup-menus thereafter to appear left-aligned rather than centered; this very unlikely condition can be cleared by evaluating 'PopUpMenu alignment: 2'" | saveAlignment result | Smalltalk isMorphic ifFalse: [saveAlignment _ PopUpMenu alignment. PopUpMenu leftFlush]. [result _ self startUp] ensure: [Smalltalk isMorphic ifFalse: [PopUpMenu alignment: saveAlignment]]. ^ result! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'! startUpCenteredWithCaption: captionOrNil "Differs from startUpWithCaption: by appearing with cursor in the menu, and thus ready to act on mouseUp, without requiring user tweak to confirm" ^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint - (20@0)! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'yo 3/15/2005 12:55'! startUpSegmented: segmentHeight withCaption: captionOrNil at: location "This menu is too big to fit comfortably on the screen. Break it up into smaller chunks, and manage the relative indices. Inspired by a special-case solution by Reinier van Loon." " (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. " | nLines nLinesPer allLabels from to subset subLines index | frame ifNil: [self computeForm]. allLabels := labelString findTokens: Character cr asString. nLines _ allLabels size. lineArray ifNil: [lineArray _ Array new]. nLinesPer _ segmentHeight // marker height - 3. from := 1. [ true ] whileTrue: [to := (from + nLinesPer) min: nLines. subset := allLabels copyFrom: from to: to. subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated]) before: subset first. subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. subLines _ (Array with: 1) , subLines. index := (PopUpMenu labels: subset asStringWithCr lines: subLines) startUpWithCaption: captionOrNil at: location. index = 1 ifTrue: [from := to + 1. from > nLines ifTrue: [ from := 1 ]] ifFalse: [index = 0 ifTrue: [^ 0]. ^ from + index - 2]]! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'yo 3/15/2005 12:55'! startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean "This menu is too big to fit comfortably on the screen. Break it up into smaller chunks, and manage the relative indices. Inspired by a special-case solution by Reinier van Loon. The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)" " (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. " | nLines nLinesPer allLabels from to subset subLines index | frame ifNil: [self computeForm]. allLabels := labelString findTokens: Character cr asString. nLines _ allLabels size. lineArray ifNil: [lineArray _ Array new]. nLinesPer _ segmentHeight // marker height - 3. from := 1. [ true ] whileTrue: [to := (from + nLinesPer) min: nLines. subset := allLabels copyFrom: from to: to. subset add: (to = nLines ifTrue: ['start over...' translated] ifFalse: ['more...' translated]) before: subset first. subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. subLines _ (Array with: 1) , subLines. index := (PopUpMenu labels: subset asStringWithCr lines: subLines) startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean. index = 1 ifTrue: [from := to + 1. from > nLines ifTrue: [ from := 1 ]] ifFalse: [index = 0 ifTrue: [^ 0]. ^ from + index - 2]]! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 3/18/2001 00:55'! startUpWithCaption: captionOrNil "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." ^ self startUpWithCaption: captionOrNil at: (ActiveHand ifNil:[Sensor]) cursorPoint! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'ar 12/27/2001 22:47'! startUpWithCaption: captionOrNil at: location "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle." ^ self startUpWithCaption: captionOrNil at: location allowKeyboard: Preferences menuKeyboardControl! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'jrp 10/4/2004 16:06'! startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, Answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard." | maxHeight | (ProvideAnswerNotification signal: captionOrNil) ifNotNilDo: [:answer | ^ selection _ answer ifTrue: [1] ifFalse: [2]]. maxHeight _ Display height*3//4. self frameHeight > maxHeight ifTrue: [^ self startUpSegmented: maxHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean]. Smalltalk isMorphic ifTrue:[ selection _ Cursor normal showWhile: [(MVCMenuMorph from: self title: captionOrNil) invokeAt: location in: ActiveWorld allowKeyboard: aBoolean]. ^ selection]. frame ifNil: [self computeForm]. Cursor normal showWhile: [self displayAt: location withCaption: captionOrNil during: [self controlActivity]]. ^ selection! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sw 12/17/2001 17:01'! startUpWithoutKeyboard "Display and make a selection from the receiver as long as the button is pressed. Answer the current selection. Do not allow keyboard input into the menu" ^ self startUpWithCaption: nil at: ((ActiveHand ifNil:[Sensor]) cursorPoint) allowKeyboard: false! ! !PopUpMenu methodsFor: 'private' stamp: 'BG 8/6/2003 12:34'! computeForm "Compute and answer a Form to be displayed for this menu." | borderInset paraForm menuForm inside | borderInset _ 4@4. paraForm _ (DisplayText text: labelString asText textStyle: MenuStyle) form. menuForm _ Form extent: paraForm extent + (borderInset * 2) depth: paraForm depth. menuForm fill: (0 @ 0 extent: menuForm extent) rule: Form over fillColor: Color white. menuForm borderWidth: 2. paraForm displayOn: menuForm at: borderInset. lineArray == nil ifFalse: [lineArray do: [ :line | menuForm fillBlack: (4 @ ((line * font height) + borderInset y) extent: (menuForm width - 8 @ 1))]]. frame _ Quadrangle new. frame region: menuForm boundingBox. frame borderWidth: 4. inside _ frame inside. marker _ inside topLeft extent: (inside width @ MenuStyle lineGrid). selection _ 1. ^ form _ menuForm ! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:41'! alignment ^ MenuStyle alignment! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:46'! alignment: anAlignment ^ MenuStyle alignment: anAlignment! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'jla 4/2/2001 20:56'! leftFlush MenuStyle leftFlush! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'nk 9/1/2004 10:27'! setMenuFontTo: aFont "Set the menu font as indicated" MenuStyle _ TextStyle fontArray: { aFont }. MenuStyle gridForFont: 1 withLead: 0; centered. self allSubInstancesDo: [:m | m rescan]! ! !PopUpMenu class methodsFor: 'instance creation' stamp: 'nk 8/30/2004 07:59'! withCaption: cap chooseFrom: labels "Simply put up a menu. Get the args in the right order with the caption first. labels may be either an array of items or a string with CRs in it. May use backslashes for returns." ^ (labels isString ifTrue: [self labels: labels withCRs lines: nil] ifFalse: [self labelArray: labels lines: nil]) startUpWithCaption: cap withCRs! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 9/5/2003 18:24'! confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." "PopUpMenu confirm: 'Are you hungry?'" ^ self confirm: queryString trueChoice: 'Yes' translated falseChoice: 'No' translated! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 9/5/2003 18:23'! confirm: queryString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." "PopUpMenu confirm: 'Reboot universe' orCancel: [^'Nevermind']" | menu choice | menu _ PopUpMenu labelArray: {'Yes' translated. 'No' translated. 'Cancel' translated}. choice _ menu startUpWithCaption: queryString. choice = 1 ifTrue: [^ true]. choice = 2 ifTrue: [^ false]. ^ cancelBlock value! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'dgd 9/5/2003 18:34'! inform: aString "PopUpMenu inform: 'I like Squeak'" (PopUpMenu labels: ' OK ' translated) startUpWithCaption: aString! ! !PortugueseLexiconServer methodsFor: 'as yet unclassified' stamp: 'tk 6/30/2000 12:02'! parts | divider | "return the parts of speech this word can be. Keep the streams for each" parts _ OrderedCollection new. partStreams _ OrderedCollection new. rwStream ifNil: [self stream]. rwStream reset. rwStream match: 'Palavra desconhecida pelo Dicion·rio.'. rwStream atEnd ifFalse: [^ #()]. "not in dictionary" rwStream reset. rwStream match: (divider _ '<li>'). "stemming a complex word" rwStream atEnd ifTrue: [rwStream reset. rwStream match: (divider _ '<dd>')]. "base word in dict" [rwStream atEnd] whileFalse: [ partStreams add: (ReadStream on: (rwStream upToAll: divider))]. partStreams do: [:pp | parts add: (pp upToAll: '</b>')]. parts size = 0 ifTrue: [^ parts]. parts last = '' ifTrue: [parts removeLast. partStreams removeLast]. "May want to remove all after </dl>" ^ parts ! ! !PortugueseLexiconServer class methodsFor: 'as yet unclassified' stamp: 'ads 4/1/2003 19:25'! openScamperOn: aWord | aUrl scamperWindow | "Open a Scamper web browser on the web dictionary entry for this word. If Scamper is already pointing at it, use the same browser. Special code for this server." aUrl _ 'http://www.priberam.pt/scripts/dlpouniv.dll', '?search_value=', (self decodeAccents: aWord). scamperWindow _ (WebBrowser default ifNil: [^self]) newOrExistingOn: aUrl. scamperWindow model jumpToUrl: aUrl asUrl. scamperWindow activate. ! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:03'! back "Go back one element and return it. Use indirect messages in case I am a StandardFileStream" self position = 0 ifTrue: [self errorCantGoBack]. self position = 1 ifTrue: [self position: 0. ^ nil]. self skip: -2. ^ self next ! ! !PositionableStream methodsFor: 'accessing' stamp: 'tk 9/23/2001 01:14'! last "Return the final element in the receiver" ^ collection at: position! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 8/12/2003 16:56'! next: anInteger putAll: aCollection startingAt: startIndex "Store the next anInteger elements from the given collection." (startIndex = 1 and:[anInteger = aCollection size]) ifTrue:[^self nextPutAll: aCollection]. ^self nextPutAll: (aCollection copyFrom: startIndex to: startIndex+anInteger-1)! ! !PositionableStream methodsFor: 'accessing' stamp: 'nk 3/18/2004 08:52'! nextWordsInto: aBitmap "Fill the word based buffer from my collection. Stored on stream as Big Endian. Optimized for speed. Read in BigEndian, then restoreEndianness." | blt pos source byteSize | collection class isBytes ifFalse: [^ self next: aBitmap size into: aBitmap startingAt: 1]. byteSize := aBitmap byteSize. "is the test on collection basicSize \\ 4 necessary?" ((self position bitAnd: 3) = 0 and: [ (collection basicSize bitAnd: 3) = 0]) ifTrue: [source := collection. pos := self position. self skip: byteSize] ifFalse: ["forced to copy it into a buffer" source := self next: byteSize. pos := 0]. "Now use BitBlt to copy the bytes to the bitmap." blt := (BitBlt current toForm: (Form new hackBits: aBitmap)) sourceForm: (Form new hackBits: source). blt combinationRule: Form over. "store" blt sourceX: 0; sourceY: pos // 4; height: byteSize // 4; width: 4. blt destX: 0; destY: 0. blt copyBits. "And do whatever the bitmap needs to do to convert from big-endian order." aBitmap restoreEndianness. ^ aBitmap "May be WordArray, ColorArray, etc" ! ! !PositionableStream methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:02'! peekBack "Return the element at the previous position, without changing position. Use indirect messages in case self is a StandardFileStream." | element | element _ self back. self skip: 1. ^ element! ! !PositionableStream methodsFor: 'accessing' stamp: 'BG 2/19/2004 14:06'! upToEnd "Answer a subcollection from the current access position through the last element of the receiver." | newStream | newStream _ WriteStream on: (collection species new: 100). [self atEnd] whileFalse: [ newStream nextPut: self next ]. ^ newStream contents! ! !PositionableStream methodsFor: 'positioning' stamp: 'tk 3/22/2002 19:33'! backUpTo: subCollection "Back up the position to he subCollection. Position must be somewhere within the stream initially. Leave it just after it. Return true if succeeded. No wildcards, and case does matter." "Example: | strm | strm _ ReadStream on: 'zabc abdc'. strm setToEnd; backUpTo: 'abc'; position " | pattern startMatch | pattern _ ReadStream on: subCollection reversed. startMatch _ nil. [pattern atEnd] whileFalse: [self position = 0 ifTrue: [^ false]. self skip: -1. (self next) = (pattern next) ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]] ifFalse: [pattern position: 0. startMatch ifNotNil: [ self position: startMatch-1. startMatch _ nil]]. self skip: -1]. self position: startMatch. ^ true ! ! !PositionableStream methodsFor: 'positioning' stamp: 'mir 6/29/2004 17:35'! positionOfSubCollection: subCollection "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. If no such match is found, answer 0." ^self positionOfSubCollection: subCollection ifAbsent: [0]! ! !PositionableStream methodsFor: 'positioning' stamp: 'avi 12/5/2004 17:41'! positionOfSubCollection: subCollection ifAbsent: exceptionBlock "Return a position such that that element at the new position equals the first element of sub, and the next elements equal the rest of the elements of sub. Begin the search at the current position. If no such match is found, answer the result of evaluating argument, exceptionBlock." | pattern startPosition currentPosition | pattern _ ReadStream on: subCollection. startPosition := self position. [pattern atEnd] whileFalse: [self atEnd ifTrue: [^exceptionBlock value]. self next = pattern next ifFalse: [pattern reset]]. currentPosition := self position. self position: startPosition. ^pattern atEnd ifTrue: [currentPosition + 1 - subCollection size] ifFalse: [exceptionBlock value]! ! !PositionableStream methodsFor: 'positioning' stamp: 'mir 5/14/2003 18:45'! pushBack: aString "Compatibility with SocketStreams" self skip: aString size negated! ! !PositionableStream methodsFor: 'positioning'! skip: anInteger "Set the receiver's position to be the current position+anInteger. A subclass might choose to be more helpful and select the minimum of the receiver's size and position+anInteger, or the maximum of 1 and position+anInteger for the repositioning." self position: position + anInteger! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'ajh 1/18/2002 01:02'! backChunk "Answer the contents of the receiver back to the previous terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator _ $!!. out _ WriteStream on: (String new: 1000). [(ch _ self back) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peekBack == terminator ifTrue: [ self back. "skip doubled terminator" ] ifFalse: [ ^ out contents reversed "we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents reversed! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 8/7/2003 13:04'! basicNextChunk "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator _ $!!. out _ WriteStream on: (String new: 1000). self skipSeparators. [(ch _ self next) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peek == terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ out contents! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:40'! checkForPreamble: chunk ((chunk beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil]) ifTrue: [ChangeSet current preambleString: chunk]. ((chunk beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil]) ifTrue: [ChangeSet current postscriptString: chunk]. ! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 19:02'! copyMethodChunkFrom: aStream at: pos "Copy the next chunk from aStream (must be different from the receiver)." | chunk | aStream position: pos. chunk _ aStream nextChunkText. chunk runs values size = 1 "Optimize for unembellished text" ifTrue: [self nextChunkPut: chunk asString] ifFalse: [self nextChunkPutWithStyle: chunk]! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 10/15/2003 15:36'! copyPreamble: preamble from: aStream at: pos "Look for a changeStamp for this method by peeking backward. Write a method preamble, with that stamp if found." | terminator methodPos p last50 stamp i | terminator _ $!!. "Look back to find stamp in old preamble, such as... Polygon methodsFor: 'private' stamp: 'di 6/25/97 21:42' prior: 34957598!! " aStream position: pos. methodPos _ aStream position. (aStream isMemberOf: MultiByteFileStream) ifTrue: [ aStream position: (p _ 0 max: methodPos-100). last50 _ aStream basicNext: methodPos - p. ] ifFalse: [ aStream position: (p _ 0 max: methodPos-50). last50 _ aStream next: methodPos - p. ]. stamp _ String new. (i _ last50 findLastOccuranceOfString: 'stamp:' startingAt: 1) > 0 ifTrue: [stamp _ (last50 copyFrom: i+8 to: last50 size) copyUpTo: $']. "Write the new preamble, with old stamp if any." self cr; nextPut: terminator. self nextChunkPut: (String streamContents: [:strm | strm nextPutAll: preamble. stamp size > 0 ifTrue: [strm nextPutAll: ' stamp: '; print: stamp]]). self cr! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 7/29/2003 22:58'! decodeString: string andRuns: runsRaw | strm runLength runValues newString index | strm _ ReadStream on: runsRaw from: 1 to: runsRaw size. (strm peekFor: $( ) ifFalse: [^ nil]. runLength _ OrderedCollection new. [strm skipSeparators. strm peekFor: $)] whileFalse: [runLength add: (Number readFrom: strm)]. runValues _ OrderedCollection new. [strm atEnd not] whileTrue: [runValues add: (Number readFrom: strm). strm next.]. newString _ MultiString new: string size. index _ 1. runLength with: runValues do: [:length :leadingChar | index to: index + length - 1 do: [:pos | newString at: pos put: (MultiCharacter leadingChar: leadingChar code: (string at: pos) charCode). ]. index _ index + length. ]. ^ newString. ! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'NS 1/28/2004 11:22'! fileInAnnouncing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. [val := (self peekFor: $!!) ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] ifFalse: [chunk := self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk logged: true]] on: InMidstOfFileinNotification do: [:ex | ex resume: true]. self skipStyleChunk]. self close]. "Note: The main purpose of this banner is to flush the changes file." SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. self flag: #ThisMethodShouldNotBeThere. "sd" Smalltalk forgetDoIts. ^val! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'nk 7/30/2004 17:54'! fileInSilentlyAnnouncing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title." | val chunk | [self atEnd] whileFalse: [self skipSeparators. [val := (self peekFor: $!!) ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] ifFalse: [chunk := self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk logged: true]] on: InMidstOfFileinNotification do: [:ex | ex resume: true]. self skipStyleChunk]. self close. "Note: The main purpose of this banner is to flush the changes file." SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. self flag: #ThisMethodShouldNotBeThere. "sd" SystemNavigation new allBehaviorsDo: [:cl | cl removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn:]. ^val! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'yo 8/13/2003 11:59'! nextChunk "Answer the contents of the receiver, up to the next terminator character. Doubled terminators indicate an embedded terminator character." | terminator out ch | terminator _ $!!. out _ WriteStream on: (String new: 1000). self skipSeparators. [(ch _ self next) == nil] whileFalse: [ (ch == terminator) ifTrue: [ self peek == terminator ifTrue: [ self next. "skip doubled terminator" ] ifFalse: [ ^ self parseLangTagFor: out contents "terminator is not doubled; we're done!!" ]. ]. out nextPut: ch. ]. ^ self parseLangTagFor: out contents. ! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'sumim 11/20/2003 18:13'! nextChunkText "Deliver the next chunk as a Text. Decode the following ]style[ chunk if present. Position at start of next real chunk." | string runsRaw strm runs peek pos | "Read the plain text" string _ self nextChunk. "Test for ]style[ tag" pos _ self position. peek _ self skipSeparatorsAndPeekNext. peek = $] ifFalse: [self position: pos. ^ string asText]. "no tag" (self upTo: $[) = ']style' ifFalse: [self position: pos. ^ string asText]. "different tag" "Read and decode the style chunk" runsRaw _ self basicNextChunk. "style encoding" strm _ ReadStream on: runsRaw from: 1 to: runsRaw size. runs _ RunArray scanFrom: strm. ^ Text basicNew setString: string setRunsChecking: runs. ! ! !PositionableStream methodsFor: 'fileIn/Out' stamp: 'sumim 11/20/2003 18:11'! parseLangTagFor: aString | string peek runsRaw pos | string _ aString. "Test for ]lang[ tag" pos _ self position. peek _ self skipSeparatorsAndPeekNext. peek = $] ifFalse: [self position: pos. ^ string]. "no tag" (self upTo: $[) = ']lang' ifTrue: [ runsRaw _ self basicNextChunk. string _ self decodeString: aString andRuns: runsRaw ] ifFalse: [ self position: pos ]. ^ string. ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 3/1/2005 06:03'! nextString "Read a string from the receiver. The first byte is the length of the string, unless it is greater than 192, in which case the first four bytes encode the length. I expect to be in ascii mode when called (caller puts back to binary)." | length aByteArray | "read the length in binary mode" self binary. length _ self next. "first byte." length >= 192 ifTrue: [length _ length - 192. 1 to: 3 do: [:ii | length _ length * 256 + self next]]. aByteArray _ ByteArray new: length. self nextInto: aByteArray. ^aByteArray asString. ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'yo 4/16/2001 17:56'! nextStringPut: s "Append the string, s, to the receiver. Only used by DataStream. Max size of 64*256*256*256." | length | (length _ s size) < 192 ifTrue: [self nextPut: length] ifFalse: [self nextPut: (length digitAt: 4)+192. self nextPut: (length digitAt: 3). self nextPut: (length digitAt: 2). self nextPut: (length digitAt: 1)]. self nextPutAll: s asByteArray. ^s! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:09'! boolean "Answer the next boolean value from this (binary) stream." ^ self next ~= 0 ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:11'! boolean: aBoolean "Store the given boolean value on this (binary) stream." self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:43'! int16 "Answer the next signed, 16-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + (self next). n >= 16r8000 ifTrue: [n _ n - 16r10000]. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:44'! int16: anInteger "Store the given signed, 16-bit integer on this (binary) stream." | n | (anInteger < -16r8000) | (anInteger >= 16r8000) ifTrue: [self error: 'outside 16-bit integer range']. anInteger < 0 ifTrue: [n _ 16r10000 + anInteger] ifFalse: [n _ anInteger]. self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 15:15'! int32 "Answer the next signed, 32-bit integer from this (binary) stream." "Details: As a fast check for negative number, check the high bit of the first digit" | n firstDigit | n _ firstDigit _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. firstDigit >= 128 ifTrue: [n _ -16r100000000 + n]. "decode negative 32-bit integer" ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:46'! int32: anInteger "Store the given signed, 32-bit integer on this (binary) stream." | n | (anInteger < -16r80000000) | (anInteger >= 16r80000000) ifTrue: [self error: 'outside 32-bit integer range']. anInteger < 0 ifTrue: [n _ 16r100000000 + anInteger] ifFalse: [n _ anInteger]. self nextPut: (n digitAt: 4). self nextPut: (n digitAt: 3). self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 07:35'! string "Answer the next string from this (binary) stream." | size | size _ self uint16. ^ (self next: size) asString ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 12:09'! string: aString "Store the given string on this (binary) stream. The string must contain 65535 or fewer characters." aString size > 16rFFFF ifTrue: [self error: 'string too long for this format']. self uint16: aString size. self nextPutAll: aString asByteArray. ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16 "Answer the next unsigned, 16-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + (self next). ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16: anInteger "Store the given unsigned, 16-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r10000) ifTrue: [self error: 'outside unsigned 16-bit integer range']. self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24 "Answer the next unsigned, 24-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24: anInteger "Store the given unsigned, 24-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r1000000) ifTrue: [self error: 'outside unsigned 24-bit integer range']. self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint32 "Answer the next unsigned, 32-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:52'! uint32: anInteger "Store the given unsigned, 32-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r100000000) ifTrue: [self error: 'outside unsigned 32-bit integer range']. self nextPut: (anInteger digitAt: 4). self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: '*Project-SAR-fileIn' stamp: 'NS 1/28/2004 11:21'! fileInFor: client announcing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title. Does NOT handle preambles or postscripts specially." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. [ val _ (self peekFor: $!!) ifTrue: [ (Compiler evaluate: self nextChunk for: client logged: false) scanFrom: self ] ifFalse: [ chunk _ self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk for: client logged: true ]. ] on: InMidstOfFileinNotification do: [ :ex | ex resume: true]. self atEnd ifFalse: [ self skipStyleChunk ]]. self close]. "Note: The main purpose of this banner is to flush the changes file." SmalltalkImage current logChange: '----End fileIn of ' , self name , '----'. Smalltalk forgetDoIts. ^ val! ! !PositionableStream methodsFor: '*packageinfo-base' stamp: 'nk 6/17/2003 07:45'! untilEnd: aBlock displayingProgress: aString aString displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. aBlock value]].! ! !PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:08'! isShadowDrawing ^shadowColor notNil! ! !PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:06'! shadowColor ^shadowColor! ! !PostscriptCanvas methodsFor: 'accessing' stamp: 'nk 4/1/2004 19:02'! shadowColor: aColor shadowColor _ aColor.! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 12/28/2003 17:42'! deferred: ignored! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 20:34'! drawGeneralBezierShape: shapeArray color: color borderWidth: borderWidth borderColor: borderColor "shapeArray is an array of: arrays of points, each of which must have a multiple of 3 points in it. This method tries to sort the provided triplets so that curves that start and end at the same point are together." | where triplets groups g2 fillC | fillC := self shadowColor ifNil: [color]. shapeArray isEmpty ifTrue: [^ self]. where := nil. groups := OrderedCollection new. triplets := OrderedCollection new. shapeArray do: [:arr | arr groupsOf: 3 atATimeDo: [:bez | | rounded | rounded := bez roundTo: 0.001. (where isNil or: [where = rounded first]) ifFalse: [groups addLast: triplets. triplets := OrderedCollection new]. triplets addLast: rounded. where := rounded last]]. groups addLast: triplets. triplets := OrderedCollection new. "now try to merge stray groups" groups copy do: [:g1 | g1 first first = g1 last last ifFalse: ["not closed" g2 := groups detect: [:g | g ~~ g1 and: [g1 last last = g first first]] ifNone: []. g2 ifNotNil: [groups remove: g2. groups add: g2 after: g1]]]. groups do: [:g | triplets addAll: g]. where := nil. self definePathProcIn: [ :cvs | triplets do: [:shape | where ~= shape first ifTrue: [where ifNotNil: [cvs closepath]. cvs moveto: shape first]. where := cvs outlineQuadraticBezierShape: shape]] during: [ :cvs | cvs clip. cvs setLinewidth: borderWidth "*2"; fill: fillC andStroke: borderColor]! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 19:14'! drawOval: r color: c borderWidth: borderWidth borderColor: borderColor | fillC | fillC _ self shadowColor ifNil:[c]. ^ self fillOval: r color: fillC borderWidth: borderWidth borderColor: borderColor ! ! !PostscriptCanvas methodsFor: 'balloon compatibility' stamp: 'nk 4/1/2004 19:16'! drawRectangle: r color: color borderWidth: borderWidth borderColor: borderColor | fillC | fillC := self shadowColor ifNil: [color]. ^ self frameAndFillRectangle: r fillColor: fillC borderWidth: borderWidth borderColor: borderColor! ! !PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:47'! fullDraw: aMorph self comment: 'start morph: ' with: aMorph. self comment: 'level: ' with: morphLevel. self comment: 'bounds: ' with: aMorph bounds. self comment: 'corner: ' with: aMorph bounds corner. morphLevel := morphLevel + 1. self setupGStateForMorph: aMorph. aMorph fullDrawPostscriptOn: self. self endGStateForMorph: aMorph. morphLevel := morphLevel - 1. self comment: 'end morph: ' with: aMorph. self comment: 'level: ' with: morphLevel. ! ! !PostscriptCanvas methodsFor: 'drawing-general' stamp: 'nk 1/2/2004 16:00'! fullDrawBookMorph:aBookMorph ^aBookMorph fullDrawOn:self. ! ! !PostscriptCanvas methodsFor: 'drawing-polygons' stamp: 'nk 4/1/2004 19:15'! drawPolygon: vertices color: aColor borderWidth: bw borderColor: bc | fillC | fillC _ self shadowColor ifNil:[aColor]. self preserveStateDuring: [:pc | pc outlinePolygon: vertices; setLinewidth: bw; fill: fillC andStroke: ((bc isKindOf: Symbol) ifTrue: [Color gray] ifFalse: [bc])]! ! !PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 20:10'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "since postscript strokes on the line and squeak strokes inside, we need to adjust inwards" self preserveStateDuring: [:pc | pc rect: (r insetBy: borderWidth / 2); setLinewidth: borderWidth; fill: fillColor andStroke: borderColor]! ! !PostscriptCanvas methodsFor: 'drawing-rectangles' stamp: 'nk 12/29/2003 16:27'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor self preserveStateDuring: [:pc | target newpath. pc setLinewidth: 0. pc outlinePolygon: {r origin. r topRight. r topRight + (borderWidth negated @ borderWidth). r origin + (borderWidth @ borderWidth). r bottomLeft + (borderWidth @ borderWidth negated). r bottomLeft. r origin}; fill: topLeftColor andStroke: topLeftColor. target newpath. pc outlinePolygon: {r topRight. r bottomRight. r bottomLeft. r bottomLeft + (borderWidth @ borderWidth negated). r bottomRight - (borderWidth @ borderWidth). r topRight + (borderWidth negated @ borderWidth). r topRight}; fill: bottomRightColor andStroke: bottomRightColor]! ! !PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 20:46'! definePathProcIn: pathBlock during: duringBlock "Bracket the output of pathBlock (which is passed the receiver) in gsave newpath <pathBlock> closepath <duringBlock> grestore " | retval | self preserveStateDuring: [:tgt | self comment: 'begin pathProc path block'. target newpath. pathBlock value: tgt. target closepath. self comment: 'begin pathProc during block'. retval := duringBlock value: tgt. self comment: 'end pathProc']. ^ retval! ! !PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:52'! preserveStateDuring: aBlock | retval saveClip saveTransform | target preserveStateDuring: [ :innerTarget | saveClip _ clipRect. saveTransform _ currentTransformation. gstateStack addLast: currentFont. gstateStack addLast: currentColor. gstateStack addLast: shadowColor. retval _ aBlock value: self. shadowColor _ gstateStack removeLast. currentColor _ gstateStack removeLast. currentFont _ gstateStack removeLast. clipRect _ saveClip. currentTransformation _ saveTransform. ]. ^ retval ! ! !PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:48'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize | retval oldShadow | oldShadow := shadowColor. self comment: 'drawing clipped ' with: aClipRect. self comment: 'drawing transformed ' with: aDisplayTransform. self preserveStateDuring: [:inner | currentTransformation ifNil: [currentTransformation := aDisplayTransform] ifNotNil: [currentTransformation := currentTransformation composedWithLocal: aDisplayTransform]. aClipRect ifNotNil: [clipRect := aDisplayTransform globalBoundsToLocal: (clipRect intersect: aClipRect). inner rect: aClipRect; clip]. inner transformBy: aDisplayTransform. retval := aBlock value: inner]. self comment: 'end of drawing clipped ' with: aClipRect. shadowColor := oldShadow. ^ retval! ! !PostscriptCanvas methodsFor: 'drawing-support' stamp: 'nk 4/1/2004 19:41'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." | result oldShadow | oldShadow := shadowColor. self translate: delta. result _ aBlock value: self. self translate: delta negated. shadowColor := oldShadow. ^ result ! ! !PostscriptCanvas methodsFor: 'drawing-text' stamp: 'nk 4/1/2004 19:28'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c | fillC oldC | fillC := self shadowColor ifNil: [c]. self setFont: (fontOrNil ifNil: [self defaultFont]). self comment: ' text color: ' , c printString. oldC := currentColor. self setColor: fillC. self comment: ' boundsrect origin ' , boundsRect origin printString. self comment: ' origin ' , origin printString. self moveto: boundsRect origin. target print: ' ('; print: (s asString copyFrom: firstIndex to: lastIndex) asPostscript; print: ') show'; cr. self setColor: oldC.! ! !PostscriptCanvas methodsFor: 'drawing-text' stamp: 'nk 12/30/2003 17:50'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c background: b target preserveStateDuring: [ :t | self fillRectangle: boundsRect color: b ]. self drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c ! ! !PostscriptCanvas methodsFor: 'initialization' stamp: 'nk 4/1/2004 19:09'! reset super reset. origin := 0 @ 0. "origin of the top-left corner of this canvas" clipRect := 0 @ 0 corner: 10000 @ 10000. "default clipping rectangle" currentTransformation := nil. morphLevel := 0. pages := 0. gstateStack := OrderedCollection new. usedFonts := Dictionary new. initialScale := 1.0. shadowColor := nil. currentColor := nil! ! !PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:08'! canBlendAlpha ^false! ! !PostscriptCanvas methodsFor: 'testing' stamp: 'nk 1/1/2004 21:09'! isPostscriptCanvas ^true! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/29/2003 09:51'! comment: aString with: anObject target comment:aString with:anObject. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 15:34'! defineFont: aFont | psNameFor alreadyRemapped | (usedFonts includesKey: aFont) ifFalse:[ psNameFor _ self postscriptFontNameForFont: aFont. alreadyRemapped _ usedFonts includes: psNameFor. usedFonts at: aFont put: psNameFor. " here: define as Type-3 unless we think its available " " or, just remap" " I had some problems if same font remapped twice" alreadyRemapped ifFalse: [target remapFontForSqueak: psNameFor]. ].! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 20:36'! drawGradient: fillColor self comment: 'not-solid fill ' with: fillColor. self comment: ' origin ' with: fillColor origin. self comment: ' direction ' with: fillColor direction. self fill: fillColor asColor! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:54'! drawPage:aMorph self fullDrawMorph:aMorph. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:18'! drawPages:collectionOfPages collectionOfPages do:[ :page | pages _ pages + 1. target print:'%%Page: '; write:pages; space; write:pages; cr. self drawPage:page. ]. morphLevel = 0 ifTrue: [ self writeTrailer: pages ].! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:53'! endGStateForMorph: aMorph morphLevel == 1 ifTrue: [ target showpage; print: 'grestore'; cr ]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 12/28/2003 21:08'! fill: fillColor fillColor isSolidFill ifTrue: [self paint: fillColor asColor operation: #eofill] ifFalse: [self preserveStateDuring: [:inner | inner clip; drawGradient: fillColor]]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'dgd 2/21/2003 23:06'! outlinePolygon: vertices target moveto: (vertices first). 2 to: vertices size do: [:i | target lineto: (vertices at: i)]. target closepath! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:29'! outlineQuadraticBezierShape: vertices | where | 3 to: vertices size by: 3 do: [:i | | v1 v2 v3 | v1 := (vertices at: i - 2) roundTo: 0.001. v2 := (vertices at: i - 1) roundTo: 0.001. v3 := (vertices at: i) roundTo: 0.001. (v1 = v2 or: [v2 = v3]) ifTrue: [target lineto: v3] ifFalse: [target curvetoQuadratic: v3 from: v1 via: v2]. where := v3]. ^where! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 22:18'! postscriptFontNameForFont: font ^(self class postscriptFontInfoForFont: font) first ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 3/25/2004 15:36'! setFont:aFont | fInfo | aFont = currentFont ifTrue: [^self]. currentFont _ aFont. self defineFont: aFont. fInfo _ self class postscriptFontInfoForFont: aFont. target selectflippedfont: fInfo first size: (aFont pixelSize * fInfo second) ascent: aFont ascent. ! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:42'! setupGStateForMorph: aMorph morphLevel == 1 ifTrue: [self writePageSetupFor: aMorph]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'gm 2/24/2003 18:07'! stroke: strokeColor strokeColor ifNil: [^self]. (strokeColor isKindOf: Symbol) ifTrue: [^self paint: Color gray operation: #stroke "punt"]. strokeColor isSolidFill ifTrue: [^self paint: strokeColor asColor operation: #stroke]. self preserveStateDuring: [:inner | inner strokepath; fill: strokeColor]! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 19:28'! text: s at: point font: fontOrNil color: c spacePad: pad | fillC oldC | fillC := self shadowColor ifNil: [c]. self setFont: (fontOrNil ifNil: [self defaultFont]). self comment: ' text color: ' , c printString. oldC := currentColor. self setColor: fillC. self comment: ' origin ' , origin printString. self moveto: point. target write: pad; print: ' 0 32 ('; print: s asPostscript; print: ') widthshow'; cr. self setColor: oldC.! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 4/1/2004 19:27'! textStyled: s at: ignored0 font: ignored1 color: c justified: justify parwidth: parwidth | fillC oldC | fillC := c. self shadowColor ifNotNilDo: [:sc | self comment: ' shadow color: ' , sc printString. fillC := sc]. self comment: ' text color: ' , c printString. oldC := currentColor. self setColor: fillC. self comment: ' origin ' , origin printString. "self moveto: point." "now done by sender" target print: ' ('; print: s asPostscript; print: ') '. justify ifTrue: [target write: parwidth; print: ' jshow'; cr] ifFalse: [target print: 'show']. target cr. self setColor: oldC.! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 20:24'! writeGlobalSetup: rotateFlag target print: '%%EndProlog'; cr. target print: '%%BeginSetup'; cr. target print: '% initialScale: '; write: initialScale; cr. target print: '% pageBBox: '; write: self pageBBox; cr. target print: '% pageOffset'; cr. target translate: self pageOffset. rotateFlag ifTrue: ["no translate needed for 0,0 = upper LH corner of page" target print: '90 rotate'; cr; print: '0 0 translate'; cr] ifFalse: [target write: 0 @ topLevelMorph height * initialScale; print: ' translate'; cr]. target print: '% flip'; cr. target scale: initialScale @ initialScale negated; print: ' [ {true setstrokeadjust} stopped ] pop'; cr. target print: '%%EndSetup'; cr! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/1/2004 17:50'! writeHeaderRotated: rotateFlag self writePSIdentifierRotated: rotateFlag. self writeProcset. self writeGlobalSetup: rotateFlag.! ! !PostscriptCanvas methodsFor: 'private' stamp: 'nk 1/2/2004 16:37'! writePageSetupFor: aMorph target print: '%%BeginPageSetup'; cr. target print: 'gsave'; cr. target translate: aMorph bounds origin negated. target print: '%%EndPageSetup'; cr! ! !PostscriptCanvas methodsFor: 'morph drawing' stamp: 'nk 1/2/2004 15:44'! writeTrailer: pages target print: '%%Trailer'; cr. usedFonts isEmpty ifFalse: [target print: '%%DocumentFonts:'. usedFonts values asSet do: [:f | target space; print: f]. target cr]. target print:'%%Pages: '; write: pages; cr. target print: '%%EOF'; cr! ! !PostscriptCanvas class methodsFor: 'configuring' stamp: 'nk 12/29/2003 13:19'! defaultExtension ^ '.ps'! ! !PostscriptCanvas class methodsFor: 'testing' stamp: 'nk 1/1/2004 20:21'! morphAsPostscript:aMorph rotated:rotateFlag offsetBy:offset | psCanvas | psCanvas _ self new. psCanvas reset. psCanvas bounds: (0@0 extent: (aMorph bounds extent + (2 * offset))). psCanvas topLevelMorph:aMorph. psCanvas resetContentRotated: rotateFlag. psCanvas fullDrawMorph: aMorph . ^psCanvas contents. ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:32'! convertFontName: aName "Break apart aName on case boundaries, inserting hyphens as needed." | lastCase | lastCase _ aName first isUppercase. ^ String streamContents: [ :s | aName do: [ :c | | thisCase | thisCase _ c isUppercase. (thisCase and: [ lastCase not ]) ifTrue: [ s nextPut: $- ]. lastCase _ thisCase. s nextPut: c ]]! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 22:20'! fontMap "Answer the font mapping dictionary. Made into a class var so that it can be edited." ^FontMap ifNil: [ self initializeFontMap. FontMap ].! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 16:06'! fontSampler "Produces a Postscript .eps file on disk, returns a Morph." "PostscriptCanvas fontSampler" "PostscriptCanvas fontSampler openInWorld" | morph file | morph _ Morph new layoutPolicy: TableLayout new; listDirection: #topToBottom; wrapDirection: #leftToRight; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color white. TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style | { style fontArray first. style fontArray last } do: [ :baseFont | | info | 0 to: 2 do: [ :i | | font string string2 textMorph row | font _ baseFont emphasized: i. (i isZero or: [ font ~~ baseFont ]) ifTrue: [ string _ font fontNameWithPointSize. row _ Morph new layoutPolicy: TableLayout new; listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap; cellSpacing: 20@0; color: Color white. textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string. row addMorphBack: (textMorph imageForm asMorph). info _ self postscriptFontInfoForFont: font. string2 _ String streamContents: [ :stream | stream nextPutAll: info first; space; print: (font pixelSize * info second) rounded. ]. textMorph _ TextMorph new hResizing: #spaceFill; backgroundColor: Color white; beAllFont: font; contentsAsIs: string2. row addMorphBack: textMorph. morph addMorphBack: row. ] ] ] ]. morph bounds: World bounds. morph layoutChanged; fullBounds. file _ (FileDirectory default newFileNamed: 'PSFontSampler.eps'). Cursor wait showWhile: [ file nextPutAll: (EPSCanvas morphAsPostscript: morph) ]. ^morph! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForAccuAt | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica-Bold' 1.0); at: 1 put: #('Helvetica-Bold' 1.0); at: 2 put: #('Helvetica-BoldOblique' 1.0); at: 3 put: #('Helvetica-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForComicBold | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow-Bold' 0.9); at: 1 put: #('Helvetica-Narrow-Bold' 0.9); at: 2 put: #('Helvetica-Narrow-BoldOblique' 0.9); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForComicPlain | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" "how do we do underlined??" d _ Dictionary new. d at: 0 put: #('Helvetica-Narrow' 0.9); at: 1 put: #('Helvetica-Narrow-Bold' 0.9); at: 2 put: #('Helvetica-Narrow-Oblique' 0.9); at: 3 put: #('Helvetica-Narrow-BoldOblique' 0.9). ^d ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForHelvetica | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Helvetica' 1.0); at: 1 put: #('Helvetica-Bold' 1.0); at: 2 put: #('Helvetica-Oblique' 1.0); at: 3 put: #('Helvetica-BoldOblique' 1.0); at: 8 put: #('Helvetica-Narrow' 1.0); at: 9 put: #('Helvetica-Narrow-Bold' 1.0); at: 10 put: #('Helvetica-Narrow-Oblique' 1.0); at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForNewYork | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Times-Roman' 1.0); at: 1 put: #('Times-Bold' 1.0); at: 2 put: #('Times-Italic' 1.0); at: 3 put: #('Times-BoldItalic' 1.0); at: 8 put: #('Helvetica-Narrow' 1.0); at: 9 put: #('Helvetica-Narrow-Bold' 1.0); at: 10 put: #('Helvetica-Narrow-Oblique' 1.0); at: 11 put: #('Helvetica-Narrow-BoldOblique' 1.0). ^d! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/2/2004 01:27'! fontsForPalatino | d | "Bold = 1, Ital = 2, Under = 4, Narrow = 8, Struckout = 16" d _ Dictionary new. d at: 0 put: #('Palatino-Roman' 1.0); at: 1 put: #('Palatino-Bold' 1.0); at: 2 put: #('Palatino-Italic' 1.0); at: 3 put: #('Palatino-BoldItalic' 1.0). ^d ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 1/1/2004 23:05'! initializeFontMap "Initialize the dictionary mapping font names to substitutions for Postscript code generation." "PostscriptCanvas initializeFontMap" | f | FontMap := Dictionary new. FontMap at: 'NewYork' put: (f _ self fontsForNewYork); at: 'Accuny' put: f; at: 'Helvetica' put: (f _ self fontsForHelvetica); at: 'Accujen' put: f; at: 'Palatino' put: self fontsForPalatino; at: 'ComicBold' put: (f _ self fontsForComicBold); at: 'Accuat' put: self fontsForAccuAt; at: 'ComicPlain' put: self fontsForComicPlain! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 20:13'! postscriptFontInfoForFont: font | fontName decoded desired mask decodedName keys match | fontName _ font textStyleName asString. decoded _ TextStyle decodeStyleName: fontName. decodedName _ decoded second. keys _ self fontMap keys asArray sort: [ :a :b | a size > b size ]. match _ keys select: [ :k | decoded first = k or: [ fontName = k ] ]. match do: [ :key | | subD | subD := self fontMap at: key. desired _ font emphasis. mask _ 31. [ desired _ desired bitAnd: mask. subD at: desired ifPresent: [ :answer | ^answer]. mask _ mask bitShift: -1. desired > 0 ] whileTrue. ]. "No explicit lookup found; try to convert the style name into the canonical Postscript name. This name will probably still be wrong." fontName _ String streamContents: [ :s | s nextPutAll: decodedName. decoded third do: [ :nm | s nextPut: $-; nextPutAll: nm ]. (font emphasis == 0 and: [ (decoded last includes: 0) not ]) ifTrue: [ s nextPutAll: '-Regular' ]. (font emphasis == 1 and: [ (decoded first anyMask: 1) not ]) ifTrue: [ s nextPutAll: '-Bold' ]. (font emphasis == 2 and: [ (decoded first anyMask: 2) not ]) ifTrue: [ s nextPutAll: '-Italic' ]. (font emphasis == 3 and: [ (decoded first anyMask: 3) not ]) ifTrue: [ s nextPutAll: '-BoldItalic' ]. ]. ^ {fontName. 1.0} ! ! !PostscriptCanvas class methodsFor: 'font mapping' stamp: 'nk 3/25/2004 15:55'! postscriptFontMappingSummary " Transcript nextPutAll: PostscriptCanvas postscriptFontMappingSummary ; endEntry " | stream | stream _ WriteStream on: (String new: 1000). TextStyle actualTextStyles keysAndValuesDo: [ :styleName :style | stream nextPutAll: styleName; cr. style fontArray do: [ :baseFont | | info | 0 to: 3 do: [ :i | | font | font _ baseFont emphasized: i. font emphasis = i ifTrue: [ stream tab; nextPutAll: font fontNameWithPointSize; tab. info _ self postscriptFontInfoForFont: font. stream nextPutAll: info first; space; print: (font pixelSize * info second) rounded. stream cr. ] ] ] ]. ^stream contents! ! !PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'RAA 5/8/2001 10:01'! addEmphasis: emphasisCode emphasis _ emphasis bitOr: emphasisCode.! ! !PostscriptCharacterScanner methodsFor: 'textstyle support' stamp: 'nk 6/10/2004 13:32'! setAlignment: alignment self paragraph textStyle alignment: alignment.! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 4/1/2004 20:16'! clip self print: 'clip'; cr. ! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/28/2003 21:09'! eofill self print: 'eofill'; cr. ! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 4/1/2004 20:16'! newpath self print: 'newpath'; cr. ! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/29/2003 15:56'! preserveStateDuring: aBlock "Note that this method supplies self, an encoder, to the block" | retval | self print: 'gsave'; cr. retval := aBlock value: self. self print: 'grestore'; cr. ^ retval! ! !PostscriptEncoder methodsFor: 'Postscript generation' stamp: 'nk 12/30/2003 17:24'! rect: aRect self newpath. self moveto:aRect topLeft; lineto:aRect topRight x @ aRect topRight y; lineto:aRect bottomRight x @ aRect bottomRight y; lineto:aRect bottomLeft x @ aRect bottomLeft y; closepath. ! ! !PowerManagement class methodsFor: 'startup logic' stamp: 'sd 4/29/2003 22:05'! startUp [Preferences turnOffPowerManager ifTrue: [self disablePowerManager]] ifError: []! ! !PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:55'! disablePowerManager self disablePowerManager: 1! ! !PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:56'! disablePowerManager: aInteger "Disable/Enable the architectures power manager by passing in nonzero or zero" <primitive: 'primitiveDisablePowerManager'> "primitiveExternalCall" ^ self! ! !PowerManagement class methodsFor: 'power management' stamp: 'sd 4/29/2003 21:57'! enablePowerManager self disablePowerManager: 0! ! !PowerManagement class methodsFor: 'computing' stamp: 'md 10/26/2003 13:07'! itsyVoltage "On the Itsy, answer the approximate Vcc voltage. The Itsy will shut itself down when this value reaches 2.0 volts. This method allows one to build a readout of the current battery condition." | n | n _ SmalltalkImage current getSystemAttribute: 1200. n ifNil: [^ 'no voltage attribute']. ^ (n asNumber / 150.0 roundTo: 0.01) asString , ' volts'! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'nk 2/12/2003 23:00'! createMethod model createMethod! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'yo 3/15/2005 13:07'! setBalloonTextForCloseBox closeBox ifNotNil: [closeBox setBalloonText: 'abandon this execution by closing this window' translated]. ! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'mir 11/10/2003 15:15'! storeLog model storeLog! ! !PreDebugWindow methodsFor: 'initialization' stamp: 'aoy 2/15/2003 21:39'! initialize | aFont proceedLabel debugLabel aWidth | super initialize. true ifFalse: ["Preferences optionalMorphicButtons" (aWidth := self widthOfFullLabelText) > 280 ifTrue: [^self]. "No proceed/debug buttons if title too long" debugLabel := aWidth > 210 ifTrue: ["Abbreviated buttons if title pretty long" proceedLabel := 'p'. 'd'] ifFalse: ["Full buttons if title short enough" proceedLabel := 'proceed'. 'debug']. aFont := Preferences standardButtonFont. self addMorph: (proceedButton := (SimpleButtonMorph new) borderWidth: 0; label: proceedLabel font: aFont; color: Color transparent; actionSelector: #proceed; target: self). proceedButton setBalloonText: 'continue execution'. self addMorph: (debugButton := (SimpleButtonMorph new) borderWidth: 0; label: debugLabel font: aFont; color: Color transparent; actionSelector: #debug; target: self). debugButton setBalloonText: 'bring up a debugger'. proceedButton submorphs first color: Color blue. debugButton submorphs first color: Color red]. self adjustBookControls! ! !Preference methodsFor: 'initialization' stamp: 'sw 4/29/2001 23:51'! categoryList: aList "Set the receiver's categoryList" categoryList _ aList! ! !Preference methodsFor: 'initialization' stamp: 'hpt 9/26/2004 15:59'! name: aName defaultValue: aValue helpString: aString localToProject: projectBoolean categoryList: aList changeInformee: informee changeSelector: aChangeSelector viewRegistry: aViewRegistry "Initialize the preference from the given values. There is an extra tolerence here for the symbols #true, #false, and #nil, which are interpreted, when appropriate, as meaning true, false, and nil" name := aName asSymbol. defaultValue := aValue. aValue = #true ifTrue: [defaultValue := true]. aValue = #false ifTrue: [defaultValue := false]. value := defaultValue. helpString := aString. localToProject := projectBoolean == true or: [projectBoolean = #true]. viewRegistry := aViewRegistry. categoryList := (aList ifNil: [OrderedCollection with: #unclassified]) collect: [:elem | elem asSymbol]. changeInformee := (informee == nil or: [informee == #nil]) ifTrue: [nil] ifFalse: [(informee isKindOf: Symbol) ifTrue: [Smalltalk at: informee] ifFalse: [informee]]. changeSelector := aChangeSelector! ! !Preference methodsFor: 'menu' stamp: 'sw 4/12/2001 23:42'! categoryList "Answer the categoryList" ^ categoryList! ! !Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:01'! copyName "Copy the name of the given preference to the clipboard" Clipboard clipboardText: name asString asText! ! !Preference methodsFor: 'menu' stamp: 'sw 4/13/2001 00:04'! helpString "Answer the help string provided for the receiver" ^ helpString ifNil: ['no help available']! ! !Preference methodsFor: 'menu' stamp: 'sw 4/10/2001 15:02'! name "Answer this preference's name" ^ name! ! !Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:01'! defaultValue "Answer this preference's defaultValue" ^ defaultValue! ! !Preference methodsFor: 'value' stamp: 'sw 4/18/2002 12:15'! defaultValue: aValue "Set the receiver's defaultValue" defaultValue _ aValue.! ! !Preference methodsFor: 'value' stamp: 'sw 4/10/2001 15:35'! preferenceValue "Answer the current value of the preference" ^ value! ! !Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'! preferenceValue: aValue "set the value as indicated, and invoke the change selector if appropriate" | oldValue | oldValue _ value. value _ aValue. oldValue ~~ value ifTrue: [self notifyInformeeOfChange]! ! !Preference methodsFor: 'value' stamp: 'sw 4/12/2001 23:28'! rawValue: aValue "set the value as indicated, with no side effects" value _ aValue! ! !Preference methodsFor: 'value' stamp: 'sw 4/12/2001 00:04'! restoreDefaultValue "restore the default value to the preference" value _ defaultValue! ! !Preference methodsFor: 'value' stamp: 'hpt 9/26/2004 16:51'! togglePreferenceValue "Toggle whether the value of the preference. Self must be a boolean preference." value := value not. self notifyInformeeOfChange! ! !Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 12:37'! isProjectLocalString "Answer a string representing whether sym is a project-local preference or not" | aStr | aStr _ 'each project has its own setting'. ^ localToProject ifTrue: ['<yes>', aStr] ifFalse: ['<no>', aStr]! ! !Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 01:14'! localToProject "Answer whether this preference is project-local" ^ localToProject! ! !Preference methodsFor: 'local to project' stamp: 'sw 4/10/2001 11:58'! toggleProjectLocalness "Toggle whether the preference should be held project-by-project or globally" localToProject _ localToProject not. PreferencesPanel allInstancesDo: [:aPanel | aPanel adjustProjectLocalEmphasisFor: name]. ! ! !Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 01:39'! changeInformee: informee changeSelector: aSelector "Set the changeInformee and changeSelector as specified" changeInformee _ informee. changeSelector _ aSelector! ! !Preference methodsFor: 'change notification' stamp: 'sw 4/12/2001 00:03'! notifyInformeeOfChange "If there is a changeInformee, notify her that I have changed value" changeInformee ifNotNil: [changeInformee perform: changeSelector]! ! !Preference methodsFor: 'debugging' stamp: 'sw 4/13/2001 00:05'! printOn: aStream "Print a string decribing the receiver to the given stream" super printOn: aStream. aStream nextPutAll: name storeString, ' ', value storeString! ! !Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'! representativeButtonWithColor: aColor inPanel: aPanel | view | view _ self viewForPanel: aPanel. ^view ifNotNil: [view representativeButtonWithColor: aColor inPanel: aPanel]! ! !Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:42'! viewClassForPanel: aPreferencePanel ^self viewRegistry viewClassFor: aPreferencePanel! ! !Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:58'! viewForPanel: aPreferencePanel | viewClass | viewClass _ self viewClassForPanel: aPreferencePanel. ^viewClass ifNotNil: [viewClass preference: self]! ! !Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'! viewRegistry ^viewRegistry! ! !Preference methodsFor: 'user interface' stamp: 'hpt 9/26/2004 15:40'! viewRegistry: aRegistry viewRegistry _ aRegistry! ! !Preference commentStamp: '<historical>' prior: 0! Represents a true/false flag that is under user control and which can be interrogated by a call to Preferences viewRegistry the registry of the classes responsible for building my view name a symbol, the formal name of the preference. value a boolean, the current value defaultValue the default value of the preference helpString string or text, constituting the help message localToProject boolean, whether each project holds its own version categoryList list of categories under which to offer this changeInformee whom, if anyone, to inform if the value changes: changeSelector what selector to send to the changeInformee when the value changes! !PreferenceView methodsFor: 'initialization' stamp: 'hpt 9/24/2004 22:25'! initializeWithPreference: aPreference preference := aPreference! ! !PreferenceView methodsFor: 'accessing' stamp: 'hpt 9/24/2004 22:25'! preference ^preference! ! !PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/24/2004 22:56'! representativeButtonWithColor: aColor inPanel: aPreferencesPanel self subclassResponsibility ! ! !PreferenceView methodsFor: 'user interface' stamp: 'hpt 9/26/2004 16:14'! tearOffButton "Hand the user a button the can control this" | aButton | aButton := self representativeButtonWithColor: self preference defaultBackgroundColor inPanel: nil. aButton borderWidth: 1; borderColor: Color black; useRoundedCorners. aButton openInHand! ! !PreferenceView commentStamp: '<historical>' prior: 0! My subclasses instances are responsible for building the visual representation of each kind of preference.! !PreferenceView class methodsFor: 'instance creation' stamp: 'hpt 9/24/2004 22:25'! preference: aPreference ^self new initializeWithPreference: aPreference; yourself! ! !PreferenceView class methodsFor: 'view registry' stamp: 'hpt 9/26/2004 16:09'! handlesPanel: aPreferencePanel self subclassResponsibility ! ! !PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! register: aProviderClass (self registeredClasses includes: aProviderClass) ifFalse: [self registeredClasses add: aProviderClass].! ! !PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! registeredClasses ^registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! !PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! unregister: aProviderClass self registeredClasses remove: aProviderClass ifAbsent: []! ! !PreferenceViewRegistry methodsFor: 'view registry' stamp: 'hpt 9/26/2004 15:26'! viewClassFor: aPreferencePanel ^self registeredClasses detect: [:aViewClass| aViewClass handlesPanel: aPreferencePanel] ifNone: [].! ! !PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'! viewOrder "answer the order in which the registered views should appear relative to the other views" ^viewOrder! ! !PreferenceViewRegistry methodsFor: 'view order' stamp: 'hpt 9/26/2004 16:22'! viewOrder: aNumber viewOrder _ aNumber! ! !PreferenceViewRegistry methodsFor: 'initialize-release' stamp: 'hpt 9/26/2004 16:22'! initialize viewOrder _ 1.! ! !PreferenceViewRegistry commentStamp: '<historical>' prior: 0! PreferenceViewRegistry is much like the AppRegistry classes. Its purpose is to allow PreferenceBrowser implementers to register its own views for each kind of preference.! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! ofBooleanPreferences ^(self registryOf: #booleanPreferences) viewOrder: 1; yourself.! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'! ofColorPreferences ^(self registryOf: #colorPreferences) viewOrder: 5; yourself.! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:24'! ofFontPreferences ^(self registryOf: #fontPreferences) viewOrder: 4; yourself.! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! ofHaloThemePreferences ^(self registryOf: #haloThemePreferences) viewOrder: 2; yourself.! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 16:23'! ofTextPreferences ^(self registryOf: #textPreferences) viewOrder: 3; yourself.! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:28'! registries ^registries ifNil: [registries _ Dictionary new]! ! !PreferenceViewRegistry class methodsFor: 'instance creation' stamp: 'hpt 9/26/2004 15:33'! registryOf: aSymbol ^self registries at: aSymbol ifAbsentPut: [self new]! ! !Preferences commentStamp: '<historical>' prior: 0! A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false. To open the control panel: Preferences openFactoredPanel To read how to use the panel (and how to make a preference be per-project): Preferences giveHelpWithPreferences All messages are on the class side. To query a a preference: Preferences logDebuggerStackToFile or some people prefer the more verbose Preferences valueOfFlag: #logDebuggerStackToFile You can make up a new preference any time. Do not define a new message in Preferences class. Accessor methods are compiled automatically when you add a preference as illustrated below: To add a preference (e.g. in the Postscript of a fileout): Preferences addPreference: #samplePreference categories: #(general browsing) default: true balloonHelp: 'This is an example of a preference added by a do-it' projectLocal: false changeInformee: nil changeSelector: nil. To change a preference programatically: Preferences disable: #logDebuggerStackToFile. Or to turn it on, Preferences enable: #logDebuggerStackToFile. ! ]style[(220 29 81 35 812)f1,f1dPreferences openFactoredPanel;;,f1,f1dPreferences giveHelpWithPreferences;;,f1! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:00'! addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:28'! addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean" self addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:01'! addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofBooleanPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! addColorPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! addColorPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofColorPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:03'! addFontPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! addFontPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofFontPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'! addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addBooleanPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString.! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 12/5/2004 13:29'! addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector "Add an item representing the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addBooleanPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 17:41'! addPreference: prefSymbol categories: categoryList default: aValue balloonHelp: helpString projectLocal: localBoolean changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry "Add or replace a preference as indicated. Reuses the preexisting Preference object for this symbol, if there is one, so that UI artifacts that interact with it will remain valid." | aPreference | aPreference := DictionaryOfPreferences at: prefSymbol ifAbsent: [Preference new]. aPreference name: prefSymbol defaultValue: aValue helpString: helpString localToProject: localBoolean categoryList: categoryList changeInformee: informeeSymbol changeSelector: aChangeSelector viewRegistry: aViewRegistry. DictionaryOfPreferences at: prefSymbol put: aPreference. self compileAccessMethodForPreference: aPreference! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:05'! addPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add the given preference, putting it in the given category, with the given default value, and with the given balloon help. It assumes boolean preference for backward compatibility" self addBooleanPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString.! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! addTextPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: categoryList default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! ! !Preferences class methodsFor: 'add preferences' stamp: 'hpt 9/26/2004 16:02'! addTextPreference: prefSymbol category: categorySymbol default: defaultValue balloonHelp: helpString "Add an item repreesenting the given preference symbol to the system. Default view for this preference is boolean to keep backward compatibility" self addPreference: prefSymbol categories: {categorySymbol} default: defaultValue balloonHelp: helpString projectLocal: false changeInformee: nil changeSelector: nil viewRegistry: PreferenceViewRegistry ofTextPreferences ! ! !Preferences class methodsFor: 'factored pref panel' stamp: 'sw 4/10/2001 14:29'! categoriesContainingPreference: prefSymbol "Return a list of all categories in which the preference occurs" ^ (self preferenceAt: prefSymbol ifAbsent: [^ #(unclassified)]) categoryList! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 7/25/2004 20:03'! attemptToRestoreClassicFonts "If certain fonts formerly used in early versions of Squeak happen to be present in the image, restore them to their corresponding roles. Not called by any other method -- intended to be invoked via do-it, possibly in a postscript" "Preferences attemptToRestoreClassicFonts" | aTextStyle | #( (setButtonFontTo: NewYork 12) (setCodeFontTo: NewYork 12) (setFlapsFontTo: ComicBold 16) (setEToysFontTo: ComicBold 16) (setListFontTo: NewYork 12) (setMenuFontTo: NewYork 12) (setWindowTitleFontTo: NewYork 15) (setSystemFontTo: NewYork 12)) do: [:triplet | (aTextStyle _ TextStyle named: triplet second) ifNotNil: [self perform: triplet first with: (aTextStyle fontOfSize: triplet third). Transcript cr; show: triplet second, ' installed as ', (triplet first copyFrom: 4 to: triplet first size - 3)]]! ! !Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:20'! chooseBalloonHelpFont BalloonMorph chooseBalloonFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'! chooseCodeFont "Not currently sent, but once protocols are sorted out so that we can disriminate on whether a text object being launched is for code or not, will be reincorporated" self chooseFontWithPrompt: 'Choose the font to be used for displaying code' translated andSendTo: self withSelector: #setCodeFontTo: highlight: self standardCodeFont.! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'! chooseEToysFont "present a menu with the possible fonts for the eToys" self chooseFontWithPrompt: 'Choose the eToys font' translated andSendTo: self withSelector: #setEToysFontTo: highlight: self standardEToysFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'! chooseFlapsFont self chooseFontWithPrompt: 'Choose a flaps font' translated andSendTo: self withSelector: #setFlapsFontTo: highlight: self standardFlapFont! ! !Preferences class methodsFor: 'fonts' stamp: 'laza 3/25/2004 23:11'! chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector self chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: nil ! ! !Preferences class methodsFor: 'fonts' stamp: 'laza 3/25/2004 23:11'! chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont Smalltalk isMorphic ifFalse: [TextStyle mvcPromptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector] ifTrue: [TextStyle promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'dgd 8/25/2004 17:14'! chooseHaloLabelFont "present a menu with the possible fonts for label in halo" self chooseFontWithPrompt: 'halo label font' andSendTo: self withSelector: #setHaloLabelFontTo: highlight: self standardHaloLabelFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:48'! chooseListFont self chooseFontWithPrompt: 'Choose the standard list font' translated andSendTo: self withSelector: #setListFontTo: highlight: self standardListFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'! chooseMenuFont self chooseFontWithPrompt: 'Choose the standard menu font' translated andSendTo: self withSelector: #setMenuFontTo: highlight: self standardMenuFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'! chooseSystemFont self chooseFontWithPrompt: 'Choose the default text font' translated andSendTo: self withSelector: #setSystemFontTo: highlight: (TextConstants at: #DefaultTextStyle) defaultFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:49'! chooseWindowTitleFont self chooseFontWithPrompt: 'Choose the window title font' translated andSendTo: self withSelector: #setWindowTitleFontTo: highlight: self windowTitleFont! ! !Preferences class methodsFor: 'fonts' stamp: 'dgd 8/25/2004 17:12'! fontConfigurationMenu | aMenu | aMenu := MenuMorph new defaultTarget: Preferences. aMenu addTitle: 'Standard System Fonts' translated. aMenu addStayUpIcons. aMenu add: 'default text font...' translated action: #chooseSystemFont. aMenu balloonTextForLastItem: 'Choose the default font to be used for code and in workspaces, transcripts, etc.' translated. aMenu lastItem font: Preferences standardDefaultTextFont. aMenu add: 'list font...' translated action: #chooseListFont. aMenu lastItem font: Preferences standardListFont. aMenu balloonTextForLastItem: 'Choose the font to be used in list panes' translated. aMenu add: 'flaps font...' translated action: #chooseFlapsFont. aMenu lastItem font: Preferences standardFlapFont. aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs' translated. aMenu add: 'eToys font...' translated action: #chooseEToysFont. aMenu lastItem font: Preferences standardEToysFont. aMenu balloonTextForLastItem: 'Choose the font to be used on eToys environment' translated. aMenu add: 'halo label font...' translated action: #chooseHaloLabelFont. aMenu lastItem font: Preferences standardHaloLabelFont. aMenu balloonTextForLastItem: 'Choose the font to be used on labels ih halo' translated. aMenu add: 'menu font...' translated action: #chooseMenuFont. aMenu lastItem font: Preferences standardMenuFont. aMenu balloonTextForLastItem: 'Choose the font to be used in menus' translated. aMenu add: 'window-title font...' translated action: #chooseWindowTitleFont. aMenu lastItem font: Preferences windowTitleFont emphasis: 1. aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.' translated. aMenu add: 'balloon-help font...' translated action: #chooseBalloonHelpFont. aMenu lastItem font: Preferences standardBalloonHelpFont. aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.' translated. aMenu add: 'code font...' translated action: #chooseCodeFont. aMenu lastItem font: Preferences standardCodeFont. aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.' translated. aMenu addLine. aMenu add: 'restore default font choices' translated action: #restoreDefaultFonts. aMenu balloonTextForLastItem: 'Use the standard system font defaults' translated. aMenu add: 'print default font choices' translated action: #printStandardSystemFonts. aMenu balloonTextForLastItem: 'Print the standard system font defaults to the Transcript' translated. ^ aMenu! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 11:37'! printStandardSystemFonts "self printStandardSystemFonts" | string | string := String streamContents: [ :s | #(standardDefaultTextFont standardListFont standardFlapFont standardEToysFont standardMenuFont windowTitleFont standardBalloonHelpFont standardCodeFont standardButtonFont) do: [:selector | | font | font _ Preferences perform: selector. s nextPutAll: selector; space; nextPutAll: font familyName; space; nextPutAll: (AbstractFont emphasisStringFor: font emphasis); nextPutAll: ' points: '; print: font pointSize; nextPutAll: ' height: '; print: font height; cr ]]. (StringHolder new) contents: string; openLabel: 'Current system font settings' translated. ! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 7/18/2004 15:34'! refreshFontSettings "Try to update all the current font settings to make things consistent." self setFlapsFontTo: (self standardFlapFont); setEToysFontTo: (self standardEToysFont); setWindowTitleFontTo: (self windowTitleFont); setListFontTo: (self standardListFont); setMenuFontTo: (self standardMenuFont); setSystemFontTo: (TextStyle defaultFont); setCodeFontTo: (self standardCodeFont); setBalloonHelpFontTo: (BalloonMorph balloonFont). SystemWindow allSubInstancesDo: [ :s | | rawLabel | rawLabel := s getRawLabel. rawLabel owner vResizing: #spaceFill. rawLabel font: rawLabel font. s setLabel: s label. s replaceBoxes ].! ! !Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:43'! restoreDefaultFonts "Since this is called from menus, we can take the opportunity to prompt for missing font styles." " Preferences restoreDefaultFonts " self setDefaultFonts: #( (setSystemFontTo: Accuny 10) (setListFontTo: Accuny 10) (setFlapsFontTo: Accushi 12) (setEToysFontTo: BitstreamVeraSansBold 9) (setPaintBoxButtonFontTo: BitstreamVeraSansBold 9) (setMenuFontTo: Accuny 10) (setWindowTitleFontTo: BitstreamVeraSansBold 12) (setBalloonHelpFontTo: Accujen 9) (setCodeFontTo: Accuny 10) (setButtonFontTo: BitstreamVeraSansMono 9) ) ! ! !Preferences class methodsFor: 'fonts' stamp: 'yo 7/28/2004 21:25'! restoreDefaultFontsForJapanese "Preferences restoreDefaultFontsForJapanese" #( "(setButtonFontTo: ComicBold 15)" "(setTextButtonFontTo: NewYork 12)" "(setCodeFontTo: NewYork 12)" "Later" (setFlapsFontTo: NewYork 15) (setListFontTo: NewYork 12) (setMenuFontTo: NewYork 12) (setWindowTitleFontTo: NewYork 15) (setSystemFontTo: NewYork 12)) do: [:triplet | self perform: triplet first with: (StrikeFontSet familyName: triplet second size: triplet third)]. self setButtonFontTo: (StrikeFont familyName: #ComicBold size: 16). Smalltalk at: #BalloonMorph ifPresent: [:thatClass | thatClass setBalloonFontTo: (StrikeFontSet familyName: #NewYork size: 12)]. "Note: The standardCodeFont is not currently used -- the default font is instead; later hopefully we can split the code font out as a separate choice, but only after we're able to have the protocols reorganized such that we can know whether it's code or not when we launch the text object. Note: The standard button font is reset by this code but is not otherwise settable by a public UI (too many things can go afoul) "! ! !Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:46'! setBalloonHelpFontTo: aFont Smalltalk at: #BalloonMorph ifPresent: [:thatClass | thatClass setBalloonFontTo: aFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 7/25/2004 17:26'! setCodeFontTo: aFont "Establish the code font." Parameters at: #standardCodeFont put: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 9/1/2004 10:19'! setDefaultFonts: defaultFontsSpec "Since this is called from menus, we can take the opportunity to prompt for missing font styles." | fontNames map emphases | fontNames _ defaultFontsSpec collect: [:array | array second]. map _ IdentityDictionary new. emphases _ IdentityDictionary new. fontNames do: [:originalName | | decoded style response | decoded := TextStyle decodeStyleName: originalName. style _ map at: originalName put: (TextStyle named: decoded second). emphases at: originalName put: decoded first. style ifNil: [ response _ TextStyle modalStyleSelectorWithTitle: 'Choose replacement for text style ', originalName. map at: originalName put: (response ifNil: [TextStyle default])]]. defaultFontsSpec do: [:triplet | self perform: triplet first with: (((map at: triplet second) fontOfPointSize: triplet third) emphasis: (emphases at: triplet second))]! ! !Preferences class methodsFor: 'fonts' stamp: 'dgd 7/12/2003 11:52'! setEToysFontTo: aFont "change the font used in eToys environment" Parameters at: #eToysFont put: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'! setHaloLabelFontTo: aFont "change the font used in eToys environment" Parameters at: #haloLabelFont put: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'! setListFontTo: aFont "Set the list font as indicated" Parameters at: #standardListFont put: aFont. ListParagraph initialize. Flaps replaceToolsFlap! ! !Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:43'! setPaintBoxButtonFontTo: aFont "change the font used in the buttons in PaintBox." Parameters at: #paintBoxButtonFont put: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 11:34'! setSystemFontTo: aFont "Establish the default text font and style" | aStyle newDefaultStyle | aFont ifNil: [^ self]. aStyle _ aFont textStyle ifNil: [^ self]. newDefaultStyle _ aStyle copy. newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont). TextConstants at: #DefaultTextStyle put: newDefaultStyle. Flaps replaceToolsFlap. ScriptingSystem resetStandardPartsBin! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 4/17/2001 13:28'! setWindowTitleFontTo: aFont "Set the window-title font to be as indicated" Parameters at: #windowTitleFont put: aFont. StandardSystemView setLabelStyle. Flaps replaceToolsFlap! ! !Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:19'! standardBalloonHelpFont ^BalloonMorph balloonFont! ! !Preferences class methodsFor: 'fonts' stamp: 'bp 6/13/2004 17:24'! standardDefaultTextFont ^TextStyle defaultFont! ! !Preferences class methodsFor: 'fonts' stamp: 'nk 7/12/2003 08:50'! standardEToysFont "Answer the font to be used in the eToys environment" ^ Parameters at: #eToysFont ifAbsent: [Parameters at: #eToysFont put: self standardButtonFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'mir 8/24/2004 12:34'! standardHaloLabelFont "Answer the font to be used in the eToys environment" ^ Parameters at: #haloLabelFont ifAbsent: [Parameters at: #haloLabelFont put: TextStyle defaultFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'yo 1/12/2005 22:40'! standardPaintBoxButtonFont "Answer the font to be used in the eToys environment" ^ Parameters at: #paintBoxButtonFont ifAbsent: [Parameters at: #paintBoxButtonFont put: self standardButtonFont]! ! !Preferences class methodsFor: 'get/set' stamp: 'dgd 8/31/2003 18:07'! automaticFlapLayoutString "Answer a string for the automaticFlapLayout menu item" ^ (self automaticFlapLayout ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'automatic flap layout' translated! ! !Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! disable: aSymbol "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" | aPreference | aPreference _ self preferenceAt: aSymbol ifAbsent: [self addPreference: aSymbol category: 'unclassified' default: false balloonHelp: 'this preference was added idiosyncratically and has no help message.'. self preferenceAt: aSymbol]. aPreference preferenceValue: false! ! !Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! enable: aSymbol "Shorthand access to enabling a preference of the given name. If there is none in the image, conjure one up" | aPreference | aPreference _ self preferenceAt: aSymbol ifAbsent: [self addPreference: aSymbol category: 'unclassified' default: true balloonHelp: 'this preference was added idiosyncratically and has no help message.'. self preferenceAt: aSymbol]. aPreference preferenceValue: true! ! !Preferences class methodsFor: 'get/set' stamp: 'sw 7/13/2001 21:34'! enableProjectNavigator "Answer whether the project-navigator menu item should be enabled" ^ true! ! !Preferences class methodsFor: 'get/set' stamp: 'dgd 8/31/2003 18:03'! navigatorShowingString "Answer a string for the show-project-navigator menu item" ^ (self showProjectNavigator ifTrue: ['<yes>'] ifFalse: ['<no>']) , 'show navigator (N)' translated! ! !Preferences class methodsFor: 'get/set' stamp: 'sw 4/12/2001 23:29'! setPreference: prefSymbol toValue: aBoolean "Set the given preference to the given value, and answer that value" ^ (self preferenceAt: prefSymbol ifAbsent: [^ aBoolean]) preferenceValue: aBoolean! ! !Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:50'! togglePreference: prefSymbol "Toggle the given preference. prefSymbol must be of a boolean preference" (self preferenceAt: prefSymbol ifAbsent: [self error: 'unknown preference: ', prefSymbol]) togglePreferenceValue! ! !Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! valueOfFlag: aFlagName "Utility method for all the preferences that are boolean, and for backward compatibility" ^self valueOfPreference: aFlagName ifAbsent: [false].! ! !Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:48'! valueOfFlag: aFlagName ifAbsent: booleanValuedBlock "the same as in #valueOfFlag:" ^self valueOfPreference: aFlagName ifAbsent: booleanValuedBlock.! ! !Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! valueOfPreference: aPreferenceSymbol "Answer the value of the given preference" ^self valueOfPreference: aPreferenceSymbol ifAbsent: []! ! !Preferences class methodsFor: 'get/set' stamp: 'hpt 9/26/2004 16:49'! valueOfPreference: aPreferenceSymbol ifAbsent: booleanValuedBlock "Answer the value of the given preference" ^ (self preferenceAt: aPreferenceSymbol ifAbsent: [^ booleanValuedBlock value]) preferenceValue! ! !Preferences class methodsFor: 'halos' stamp: 'sw 12/30/2004 01:42'! classicHaloSpecs "Non-iconic halos with traditional placements" "Preferences installClassicHaloSpecs" "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" "NB: listed below in clockwise order" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addMenuHandle: left top (red) none) (addDismissHandle: leftCenter top (red muchLighter) 'Halo-Dismiss') (addGrabHandle: center top (black) none) (addDragHandle: rightCenter top (brown) none) (addDupHandle: right top (green) none) (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addDebugHandle: right topCenter (blue veryMuchLighter) none) (addPoohHandle: right center (white) none) (addPaintBgdHandle: right center (lightGray) none) (addRepaintHandle: right center (lightGray) none) (addGrowHandle: right bottom (yellow) none) (addScaleHandle: right bottom (lightOrange) none) (addFontEmphHandle: rightCenter bottom (lightBrown darker) none) (addFontStyleHandle: center bottom (lightRed) none) (addFontSizeHandle: leftCenter bottom (lightGreen) none) (addRecolorHandle: right bottomCenter (magenta darker) none) (addRotateHandle: left bottom (blue) none)) ! ! !Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! classicHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #classicHaloSpecs! ! !Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! customHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #customHaloSpecs! ! !Preferences class methodsFor: 'halos' stamp: 'sw 10/18/2001 15:09'! haloSpecificationsForWorld | desired | "Answer a list of HaloSpecs that describe which halos are to be used on a world halo, what they should look like, and where they should be situated" "Preferences resetHaloSpecifications" desired _ #(addDebugHandle: addMenuHandle: addTileHandle: addViewHandle: addHelpHandle: addScriptHandle: addPaintBgdHandle:). ^ self haloSpecifications select: [:spec | desired includes: spec addHandleSelector]! ! !Preferences class methodsFor: 'halos' stamp: 'sw 12/29/2004 22:16'! iconicHaloSpecifications "Answer an array that characterizes the locations, colors, icons, and selectors of the halo handles that may be used in the iconic halo scheme" "Preferences resetHaloSpecifications" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addCollapseHandle: left topCenter (tan) 'Halo-Collapse') (addPoohHandle: right center (white) 'Halo-Pooh') (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addMenuHandle: leftCenter top (red) 'Halo-Menu') (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') (addViewHandle: left center (cyan) 'Halo-View') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') (addScriptHandle: rightCenter bottom (green muchLighter) 'Halo-Script') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addViewingHandle: leftCenter bottom (lightGreen lighter) 'Halo-View') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') (addChooseGraphicHandle: right bottomCenter (green muchLighter) 'Halo-ChooseGraphic') ) ! ! !Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! iconicHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #iconicHaloSpecifications! ! !Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:35'! installHaloTheme: themeSymbol self installHaloSpecsFromArray: (self perform: themeSymbol). (self preferenceAt: #haloTheme) preferenceValue: themeSymbol. ! ! !Preferences class methodsFor: 'halos' stamp: 'sw 7/28/2004 16:26'! simpleFullHaloSpecifications "This method gives the specs for the 'full' handles variant when simple halos are in effect" "Preferences resetHaloSpecifications" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addPoohHandle: right center (white) 'Halo-Pooh') (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addMenuHandle: leftCenter top (red) 'Halo-Menu') (addTileHandle: left bottomCenter (lightBrown) 'Halo-Tile') (addViewHandle: left center (cyan) 'Halo-View') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addMakeSiblingHandle: right top (green muchDarker) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addScaleHandle: right bottom (lightOrange) 'Halo-Scale') (addFewerHandlesHandle: left topCenter (paleBuff) 'Halo-FewerHandles') (addScriptHandle: right bottomCenter (green muchLighter) 'Halo-Script') (addPaintBgdHandle: right center (lightGray) 'Halo-Paint') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRecolorHandle: right bottomCenter (magenta darker) 'Halo-Recolor') ) ! ! !Preferences class methodsFor: 'halos' stamp: 'hpt 9/24/2004 23:34'! simpleHalosInForce ^ (self preferenceAt: #haloTheme) preferenceValue == #simpleFullHaloSpecifications! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'hpt 8/6/2004 23:22'! browseToolClass "This method is used for returning the appropiate class for the #browserShowsPackagePane preference. Now that preference modifies the registry so here we query directly to the registry" ^ SystemBrowser default. ! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'huma 12/1/2004 18:53'! isFlagship "Manually change this to return true if you wish your system to be marked as a 'flagship'. The intent here is to allow an update to query this flag before undertaking some radical do-it that might clobber important content in such an image." ^ false! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 8/11/2002 02:18'! messengersInViewers "A coming technology..." ^ false! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'sw 11/15/2001 08:37'! suppressWindowTitlesInInstanceBrowsers "Hard-coded for the moment: answer whether instance browsers should suppresss their window titles" ^ false! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 4/11/2001 23:52'! addPreferenceForCelesteShowingAttachmentsFlag "Assure the existence of a preference governing the showing of the celeste attachments flag" "Preferences addPreferenceForCelesteShowingAttachmentsFlag" self preferenceAt: #celesteShowsAttachmentsFlag ifAbsent: [self addPreference: #celesteShowsAttachmentsFlag category: #general default: false balloonHelp: 'If true, Celeste (e-mail reader) annotates messages in it''s list that have attachments. This is a performance hit and by default is off.']! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 4/11/2001 23:33'! addPreferenceForOptionalCelesteStatusPane "Assure existence of a preference that governs the optional celeste status pane" "Preferences addPreferenceForOptionalCelesteStatusPane" self preferenceAt: #celesteHasStatusPane ifAbsent: [self addPreference: #celesteHasStatusPane category: #general default: false balloonHelp: 'If true, Celeste (e-mail reader) includes a status pane.' "Because Lex doesn't like it the default is false :)"]! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 4/10/2001 15:28'! chooseInitialSettings "Restore the default choices for all of the standard Preferences." self allPreferenceObjects do: [:aPreference | aPreference restoreDefaultValue]. Project current installProjectPreferences! ! !Preferences class methodsFor: 'initialization' stamp: 'NS 1/28/2004 14:43'! compileAccessMethodForPreference: aPreference "Compile an accessor method for the given preference" self class compileSilently: (aPreference name, ' ^ self valueOfFlag: #', aPreference name, ' ifAbsent: [', aPreference defaultValue storeString, ']') classified: 'standard queries'! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 4/4/2001 00:09'! initializeDictionaryOfPreferences "Initialize the DictionaryOfPreferences to be an empty IdentityDictionary" "Preferences initializeDictionaryOfPreferences" DictionaryOfPreferences _ IdentityDictionary new.! ! !Preferences class methodsFor: 'initialization' stamp: 'KLC 12/11/2003 15:52'! removePreference: aSymbol "Remove all memory of the given preference symbol in my various structures." | pref | pref _ self preferenceAt: aSymbol ifAbsent: [^ self]. pref localToProject ifTrue: [ Project allInstancesDo: [:proj | proj projectPreferenceFlagDictionary ifNotNil: [ proj projectPreferenceFlagDictionary removeKey: aSymbol ifAbsent: []]]]. DictionaryOfPreferences removeKey: aSymbol ifAbsent: []. self class removeSelector: aSymbol "Preferences removePreference: #tileToggleInBrowsers" ! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 4/21/2002 05:13'! setPreferencesFrom: listOfPairs "Given a list of <preferenceName, value> pairs, set preference values. This method is tolerent of the value being supplied either a Boolean or else one of the symbols #true and #false. Also, a new-value of #noOpinion will result in that 'preference's value not being changed." listOfPairs do: [:aPair | (aPair second == #noOpinion) ifFalse: [Preferences setPreference: aPair first toValue: ((aPair second == #true) or: [aPair second == true])]] " Preferences setPreferencesFrom: #(( mouseOverForKeyboardFocus false)) Preferences setPreferencesFrom: {{ #mouseOverForKeyboardFocus. true}} "! ! !Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:06'! menuLineColor ^ Parameters at: #menuLineColor ifAbsentPut: [Preferences menuBorderColor lighter]! ! !Preferences class methodsFor: 'menu parameters' stamp: 'dgd 8/30/2004 20:59'! menuSelectionColor ^ Parameters at: #menuSelectionColor ifAbsent: [nil]! ! !Preferences class methodsFor: 'menu parameters' stamp: 'dgd 3/23/2003 11:11'! restoreDefaultMenuParameters "Restore the four color choices of the original implementors of MorphicMenus" " Preferences restoreDefaultMenuParameters " Parameters at: #menuColor put: (Color r: 0.97 g: 0.97 b: 0.97). Parameters at: #menuBorderColor put: (Color r: 0.167 g: 0.167 b: 1.0). Parameters at: #menuBorderWidth put: 2. Parameters at: #menuTitleColor put: (Color r: 0.4 g: 0.8 b: 0.9) twiceDarker. Parameters at: #menuTitleBorderColor put: (Color r: 0.333 g: 0.667 b: 0.751). Parameters at: #menuTitleBorderWidth put: 1. Parameters at: #menuLineColor put: (Preferences menuBorderColor lighter)! ! !Preferences class methodsFor: 'misc' stamp: 'dgd 9/7/2004 18:35'! balloonHelpDelayTime "Answer the number of milliseconds before a balloon help should be put up on morphs." ^ Parameters at: #balloonHelpDelayTime ifAbsent: [800]! ! !Preferences class methodsFor: 'misc' stamp: 'md 11/14/2003 17:05'! browseThemes "Open up a message-category browser on the theme-defining methods" | aBrowser | aBrowser _ Browser new setClass: Preferences class selector: #outOfTheBox. aBrowser messageCategoryListIndex: ((Preferences class organization categories indexOf: 'themes' ifAbsent: [^ self inform: 'no themes found']) + 1). Browser openBrowserView: (aBrowser openMessageCatEditString: nil) label: 'Preference themes' "Preferences browseThemes"! ! !Preferences class methodsFor: 'misc' stamp: 'gk 2/28/2005 16:42'! defaultValueTableForCurrentRelease "Answer a table defining default values for all the preferences in the release. Returns a list of (pref-symbol, boolean-symbol) pairs" ^ #( (abbreviatedBrowserButtons false) (allowCelesteTell true) (alternativeBrowseIt false) (alternativeScrollbarLook true) (alternativeWindowLook true) (annotationPanes false) (areaFillsAreTolerant false) (areaFillsAreVeryTolerant false) (autoAccessors false) (automaticFlapLayout true) (automaticKeyGeneration false) (automaticPlatformSettings true) (automaticViewerPlacement true) (balloonHelpEnabled true) (balloonHelpInMessageLists false) (batchPenTrails false) (browseWithDragNDrop false) (browseWithPrettyPrint false) (browserShowsPackagePane false) (canRecordWhilePlaying false) (capitalizedReferences true) (caseSensitiveFinds false) (cautionBeforeClosing false) (celesteHasStatusPane false) (celesteShowsAttachmentsFlag false) (changeSetVersionNumbers true) (checkForSlips true) (checkForUnsavedProjects true) (classicNavigatorEnabled false) (classicNewMorphMenu false) (clickOnLabelToEdit false) (cmdDotEnabled true) (collapseWindowsInPlace false) (colorWhenPrettyPrinting false) (compactViewerFlaps false) (compressFlashImages false) (confirmFirstUseOfStyle true) (conversionMethodsAtFileOut false) (cpuWatcherEnabled false) (debugHaloHandle true) (debugPrintSpaceLog false) (debugShowDamage false) (decorateBrowserButtons true) (diffsInChangeList true) (diffsWithPrettyPrint false) (dismissAllOnOptionClose false) (dragNDropWithAnimation false) (eToyFriendly false) (eToyLoginEnabled false) (enableLocalSave true) (extractFlashInHighQuality true) (extractFlashInHighestQuality false) (fastDragWindowForMorphic true) (fenceEnabled true) (fullScreenLeavesDeskMargins true) (haloTransitions false) (hiddenScrollBars false) (higherPerformance false) (honorDesktopCmdKeys true) (ignoreStyleIfOnlyBold true) (inboardScrollbars true) (includeSoundControlInNavigator false) (infiniteUndo false) (logDebuggerStackToFile true) (magicHalos false) (menuButtonInToolPane false) (menuColorFromWorld false) (menuKeyboardControl false) (modalColorPickers true) (mouseOverForKeyboardFocus false) (mouseOverHalos false) (mvcProjectsAllowed true) (navigatorOnLeftEdge true) (noviceMode false) (okToReinitializeFlaps true) (optionalButtons true) (passwordsOnPublish false) (personalizedWorldMenu true) (postscriptStoredAsEPS false) (preserveTrash true) (printAlternateSyntax false) (projectViewsInWindows true) (projectZoom true) (projectsSentToDisk false) (promptForUpdateServer true) (propertySheetFromHalo false) (readDocumentAtStartup true) (restartAlsoProceeds false) (reverseWindowStagger true) (roundedMenuCorners true) (roundedWindowCorners true) (scrollBarsNarrow false) (scrollBarsOnRight true) (scrollBarsWithoutMenuButton false) (securityChecksEnabled false) (selectiveHalos false) (showBoundsInHalo false) (showDirectionForSketches false) (showDirectionHandles false) (showFlapsWhenPublishing false) (showProjectNavigator false) (showSecurityStatus true) (showSharedFlaps true) (signProjectFiles true) (simpleMenus false) (slideDismissalsToTrash true) (smartUpdating true) (soundQuickStart false) (soundStopWhenDone false) (soundsEnabled true) (startInUntrustedDirectory false) (systemWindowEmbedOK false) (thoroughSenders true) (tileTranslucentDrag true) (timeStampsInMenuTitles true) (turnOffPowerManager false) (twentyFourHourFileStamps true) (twoSidedPoohTextures true) (typeCheckingInTileScripting true) (uniTilesClassic true) (uniqueNamesInHalos false) (universalTiles false) (unlimitedPaintArea false) (updateSavesFile false) (useButtonProprtiesToFire false) (useUndo true) (viewersInFlaps true) (warnAboutInsecureContent true) (warnIfNoChangesFile true) (warnIfNoSourcesFile true)) " Preferences defaultValueTableForCurrentRelease do: [:pair | (Preferences preferenceAt: pair first ifAbsent: [nil]) ifNotNilDo: [:pref | pref defaultValue: (pair last == true)]]. Preferences chooseInitialSettings. "! ! !Preferences class methodsFor: 'misc' stamp: 'sw 11/29/2003 22:05'! giveHelpWithPreferences "Open up a workspace with explanatory info in it about Preferences" | aString aHelpString | aString _ String streamContents: [:aStream | aStream nextPutAll: 'Many aspects of the system are governed by the settings of various "Preferences". Click on any of brown tabs at the top of the panel to see all the preferences in that category. Or type in to the box above the Search button, then hit Search, and all Preferences matching whatever you typed in will appear in the "search results" category. A preference is considered to match your search if either its name matches the characters *or* if anything in the balloon help provided for the preferences matches the search text. To find out more about any particular Preference, hold the mouse over it for a moment and balloon help will appear. Also, a complete list of all the Preferences, with documentation for each, is included below. Preferences whose names are in shown in bold in the Preferences Panel are designated as being allowed to vary from project to project; those whose name are not in bold are "global", which is to say, they apply equally whatever project you are in. Click on the name of any preference to get a menu which allows you to *change* whether the preference should vary from project to project or should be global, and also allows you to browse all the senders of the preference, and to discover all the categories under which the preference has been classified, and to be handed a button that you can drop wherever you please that will control the preference. If you like all your current Preferences settings, you may wish to hit the "Save Current Settings as my Personal Preferences" button. Once you have done that, you can at any point in the future hit "Restore my Personal Preferences" and all your saved settings will get restored immediately. Also, you can use "themes" to set multiple preferences all at once; click on the "change theme..." button in the Squeak flap or in the Preferences panel, or seek out the themes item in the Appearance menu.' translated. aStream cr; cr; nextPutAll: '-----------------------------------------------------------------'; cr; cr; nextPutAll: 'Alphabetical listing of all Preferences' translated; cr; cr. (Preferences allPreferenceObjects asSortedCollection: [:a :b | a name < b name]) do: [:pref | aStream nextPutAll: pref name; cr. aHelpString _ pref helpString translated. (aHelpString beginsWith: pref name) ifTrue: [aHelpString _ aHelpString copyFrom: (pref name size + 3) to: aHelpString size]. aHelpString _ (aHelpString copyReplaceAll: String cr with: ' ') copyWithout: Character tab. aStream nextPutAll: aHelpString capitalized. (aHelpString last == $.) ifFalse: [aStream nextPut: $.]. aStream cr; cr]]. (Workspace new contents: aString) openLabel: 'About Preferences' translated "Preferences giveHelpWithPreferences"! ! !Preferences class methodsFor: 'misc' stamp: 'yo 7/2/2004 19:44'! installTheme: aSymbol "Install the theme represented by aSymbol. The code that makes the theme-specific changes is lodged in a method of the same name as aSymbol, which must reside in category #themes in Preferences class" self perform: aSymbol. self inform: ('Theme {1} is now installed. Many of the changes will only be noticeable in new windows that you create from now on.' translated format: {aSymbol translated}).! ! !Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:51'! menuColorString ^ ((self valueOfFlag: #menuColorFromWorld) ifTrue: ['stop menu-color-from-world'] ifFalse: ['start menu-color-from-world']) translated! ! !Preferences class methodsFor: 'misc' stamp: 'sw 4/30/2002 01:02'! offerThemesMenu "Put up a menu offering the user a choice of themes. Each theme is represented by a method in category #themes in Preferences class. The comment at the front of each method is used as the balloon help for the theme" "Preferences offerThemesMenu" | selectors aMenu | selectors _ self class allMethodsInCategory: #themes. selectors _ selectors select: [:sel | sel numArgs = 0]. aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'Choose a theme to install'. selectors do: [:sel | aMenu add: sel target: self selector: #installTheme: argument: sel. aMenu balloonTextForLastItem: (self class firstCommentAt: sel)]. aMenu addLine. aMenu add: 'browse themes' target: self action: #browseThemes. aMenu balloonTextForLastItem: 'Puts up a tool that will allow you to view and edit the code underlying all of the available themes'. aMenu popUpInWorld. "(Workspace new contents: 'here is an example of a new window with your new theme installed') openLabel: 'Testing one two three'"! ! !Preferences class methodsFor: 'misc' stamp: 'sw 4/24/2001 12:02'! okayToChangeProjectLocalnessOf: prefSymbol "Answer whether it would be okay to allow the user to switch the setting of whether or not the preference symbol is local to a project. Formerly useful and perhaps again will be, though to be sure this is a non-modular design." ^ (#() includes: prefSymbol) not! ! !Preferences class methodsFor: 'misc' stamp: 'yo 2/10/2005 16:15'! roundedCornersString ^ (((self valueOfFlag: #roundedWindowCorners) ifTrue: ['stop'] ifFalse: ['start']) , ' rounding window corners') translated! ! !Preferences class methodsFor: 'misc' stamp: 'sw 3/2/2004 22:11'! setArrowheads "Let the user edit the size of arrowheads" | aParameter result | aParameter _ self parameterAt: #arrowSpec ifAbsent: [5 @ 4]. result _ Morph obtainArrowheadFor: 'Default size of arrowheads on pen trails ' translated defaultValue: aParameter asString. result ifNotNil: [self setParameter: #arrowSpec to: result] ifNil: [Beeper beep]! ! !Preferences class methodsFor: 'misc' stamp: 'dgd 10/17/2003 12:14'! soundEnablingString ^ self soundsEnabled ifFalse: ['turn sound on' translated] ifTrue: ['turn sound off' translated]! ! !Preferences class methodsFor: 'misc' stamp: 'dgd 9/21/2003 13:46'! staggerPolicyString "Answer the string to be shown in a menu to represent the stagger-policy status" ^ ((self valueOfFlag: #reverseWindowStagger) ifTrue: ['<yes>'] ifFalse: ['<no>']), 'stagger windows' translated! ! !Preferences class methodsFor: 'misc' stamp: 'dgd 9/1/2003 11:43'! themeChoiceButtonOfColor: aColor font: aFont "Answer a button inviting the user to choose a theme" | aButton | aButton _ SimpleButtonMorph new target: self; actionSelector: #offerThemesMenu. aButton label: 'change theme...' translated font: aFont. aButton color: aColor. aButton setBalloonText: 'Numerous "Preferences" govern many things about the way Squeak looks and behaves. Set individual preferences using a "Preferences" panel. Set an entire "theme" of many Preferences all at the same time by pressing this "change theme" button and choosing a theme to install. Look in category "themes" in Preferences class to see what each theme does; add your own methods to the "themes" category and they will show up in the list of theme choices.' translated. ^ aButton! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 6/13/2001 19:41'! annotationEditingWindow "Answer a window affording editing of annotations" | aPanel ins outs current aMorph aWindow aButton info pair standardHeight | standardHeight _ 140. Smalltalk isMorphic ifFalse: [self error: 'annotations can be edited only in morphic']. aPanel _ AlignmentMorph newRow extent: 300 @ standardHeight. ins _ AlignmentMorph newColumn extent: 150 @ standardHeight. ins color: Color green muchLighter. ins enableDrop: true; beSticky. outs _ AlignmentMorph newColumn extent: 150 @ standardHeight. outs color: Color red muchLighter. outs enableDrop: true; beSticky. aPanel addMorph: outs; addMorphFront: ins. outs position: (ins position + (200 @ 0)). current _ self defaultAnnotationRequests. info _ self annotationInfo. current do: [:sym | pair _ info detect: [:aPair | aPair first == sym]. aMorph _ StringMorph new contents: pair first. aMorph setBalloonText: pair last. aMorph enableDrag: true. aMorph on: #startDrag send: #startDrag:with: to: aMorph. ins addMorphBack: aMorph]. info do: [:aPair | (current includes: aPair first) ifFalse: [aMorph _ StringMorph new contents: aPair first. aMorph setBalloonText: aPair last. aMorph enableDrag: true. aMorph on: #startDrag send: #startDrag:with: to: aMorph. outs addMorph: aMorph]]. aPanel layoutChanged. aWindow _ SystemWindowWithButton new setLabel: 'Annotations'. aButton _ SimpleButtonMorph new target: Preferences; actionSelector: #acceptAnnotationsFrom:; arguments: (Array with: aWindow); label: 'apply'; borderWidth: 0; borderColor: Color transparent; color: Color transparent. aButton submorphs first color: Color blue. aButton setBalloonText: 'After moving all the annotations you want to the left (green) side, and all the ones you do NOT want to the right (pink) side, hit this "apply" button to have your choices take effect.'. aWindow buttonInTitle: aButton; adjustExtraButton. ^ aPanel wrappedInWindow: aWindow "Preferences annotationEditingWindow openInHand"! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 7/12/2001 18:18'! annotationInfo "Answer a list of pairs characterizing all the available kinds of annotations; in each pair, the first element is a symbol representing the info type, and the second element is a string providing the corresponding balloon help" ^ #( (timeStamp 'The time stamp of the last submission of the method.') (firstComment 'The first comment in the method, if any.') (masterComment 'The comment at the beginning of the supermost implementor of the method if any.') (documentation 'Comment at beginning of the method or, if it has none, comment at the beginning of a superclass''s implementation of the method') (messageCategory 'Which method category the method lies in') (sendersCount 'A report of how many senders there of the message.') (implementorsCount 'A report of how many implementors there are of the message.') (recentChangeSet 'The most recent change set bearing the method.') (allChangeSets 'A list of all change sets bearing the method.') (priorVersionsCount 'A report of how many previous versions there are of the method' ) (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any'))! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 6/13/2001 19:40'! editAnnotations "Put up a window that allows the user to edit annotation specifications" | aWindow | self currentWorld addMorphCentered: (aWindow _ self annotationEditingWindow). aWindow activateAndForceLabelToShow "Preferences editAnnotations" ! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 5/16/2003 00:27'! expungeParameter: aKey "If Parameters holds an entry under the given key, remove the entry. No senders in the current system, but called from the postscript of the change-set that defines it, and potentially useful otherwise." Parameters removeKey: aKey ifAbsent: []! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:52'! parameterAt: aKey default: defaultValueBlock "Deprecated interface; no surviving senders in the released image, but clients probably still use" ^ self parameterAt: aKey ifAbsentPut: defaultValueBlock! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 2/7/2001 14:37'! parameterAt: aKey ifAbsent: aBlock "Answer the parameter saved at the given key; if there is no such key in the Parameters dictionary, evaluate aBlock" ^ Parameters at: aKey ifAbsent: [aBlock value]! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 9/28/2001 08:40'! parameterAt: aKey ifAbsentPut: defaultValueBlock "Return the Parameter setting at the given key. If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value" ^ Parameters at: aKey ifAbsentPut: defaultValueBlock! ! !Preferences class methodsFor: 'personalization' stamp: 'NS 1/28/2004 14:43'! compileHardCodedPref: prefName enable: aBoolean "Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message" self class compileSilently: (prefName asString, ' "compiled programatically -- return hard-coded preference value" ^ ', aBoolean storeString) classified: 'hard-coded prefs'. "Preferences compileHardCodedPref: #testing enable: false"! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 7/30/2004 21:45'! disableProgrammerFacilities "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method. To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities. To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu: Preferences disableProgrammerFacilities. You will be prompted for a new image name under which to save the resulting image." Beeper beep. (self confirm: 'CAUTION!!!! This is a drastic step!! Do you really want to do this?') ifFalse: [Beeper beep. ^self inform: 'whew!!']. self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" self enable: #noviceMode. "No control-menu" self disable: #warnIfNoSourcesFile. self disable: #warnIfNoChangesFile. SmalltalkImage current saveAs! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 11:40'! loadPreferencesFrom: aFileName | stream params dict desktopColor | stream _ ReferenceStream fileNamed: aFileName. params _ stream next. self assert: (params isKindOf: IdentityDictionary). params removeKey: #PersonalDictionaryOfPreferences. dict _ stream next. self assert: (dict isKindOf: IdentityDictionary). desktopColor _ stream next. stream close. dict keysAndValuesDo: [:key :value | (self preferenceAt: key ifAbsent: [nil]) ifNotNilDo: [:pref | pref preferenceValue: value preferenceValue]]. params keysAndValuesDo: [ :key :value | self setParameter: key to: value ]. Smalltalk isMorphic ifTrue: [ World fillStyle: desktopColor ] ifFalse: [ self desktopColor: desktopColor. ScheduledControllers updateGray ]. ! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 7/29/2004 10:12'! personalizeUserMenu: aMenu "The user has clicked on the morphic desktop with the yellow mouse button (option+click on the Mac); a menu is being constructed to present to the user in response; its default target is the current world. In this method, you are invited to add items to the menu as per personal preferences. The default implementation, for illustrative purposes, sets the menu title to 'personal', and adds items for go-to-previous-project, show/hide flaps, and load code updates" aMenu addTitle: 'personal' translated. "Remove or modify this as per personal choice" aMenu addStayUpItem. aMenu add: 'previous project' translated action: #goBack. aMenu add: 'load latest code updates' translated target: Utilities action: #updateFromServer. aMenu add: 'about this system...' translated target: SmalltalkImage current action: #aboutThisSystem. Preferences isFlagship ifTrue: "For benefit of Alan" [aMenu addLine. aMenu add: 'start using vectors' translated target: ActiveWorld action: #installVectorVocabulary. aMenu add: 'stop using vectors' translated target: ActiveWorld action: #abandonVocabularyPreference]. aMenu addLine. aMenu addUpdating: #suppressFlapsString target: CurrentProjectRefactoring action: #currentToggleFlapsSuppressed. aMenu balloonTextForLastItem: 'Whether prevailing flaps should be shown in the project right now or not.' translated! ! !Preferences class methodsFor: 'personalization' stamp: 'sw 4/18/2002 18:02'! restorePersonalPreferences "Restore all the user's saved personal preference settings" | savedPrefs | savedPrefs _ self parameterAt: #PersonalDictionaryOfPreferences ifAbsent: [^ self inform: 'There are no personal preferences saved in this image yet']. savedPrefs associationsDo: [:assoc | (self preferenceAt: assoc key ifAbsent: [nil]) ifNotNilDo: [:pref | pref preferenceValue: assoc value preferenceValue]]! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:07'! restorePreferencesFromDisk (FileDirectory default fileExists: 'my.prefs') ifTrue: [ Cursor wait showWhile: [ [ self loadPreferencesFrom: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error restoring the preferences' ] ] ] ifFalse: [ self inform: 'you haven''t saved your preferences yet!!' ]. ! ! !Preferences class methodsFor: 'personalization' stamp: 'sw 4/10/2001 13:16'! savePersonalPreferences "Save the current list of Preference settings as the user's personal choices" self setParameter: #PersonalDictionaryOfPreferences to: DictionaryOfPreferences deepCopy! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 11:38'! storePreferencesIn: aFileName | stream | #(Prevailing PersonalPreferences) do: [ :ea | Parameters removeKey: ea ifAbsent: []]. stream _ ReferenceStream fileNamed: aFileName. stream nextPut: Parameters. stream nextPut: DictionaryOfPreferences. Smalltalk isMorphic ifTrue: [ stream nextPut: World fillStyle ] ifFalse: [ stream nextPut: DesktopColor ]. stream close.! ! !Preferences class methodsFor: 'personalization' stamp: 'nk 11/17/2002 12:08'! storePreferencesToDisk Cursor wait showWhile: [ [ self storePreferencesIn: 'my.prefs' ] on: Error do: [ :ex | self inform: 'there was an error storing your preferences to disk' ]]! ! !Preferences class methodsFor: 'preference-object access' stamp: 'sw 4/13/2001 00:06'! allPreferenceObjects "Answer a list of all the Preference objects registered in the system" ^ DictionaryOfPreferences values! ! !Preferences class methodsFor: 'preference-object access' stamp: 'sw 4/13/2001 01:06'! preferenceAt: aSymbol "Answer the Preference object at the given symbol, or nil if not there" ^ DictionaryOfPreferences at: aSymbol ifAbsent: [nil]! ! !Preferences class methodsFor: 'preference-object access' stamp: 'sw 4/13/2001 01:06'! preferenceAt: aSymbol ifAbsent: aBlock "Answer the Preference object at the given symbol, or the value of aBlock if not present" ^ DictionaryOfPreferences at: aSymbol ifAbsent: [aBlock value]! ! !Preferences class methodsFor: 'preferences panel' stamp: 'hpt 9/25/2004 11:49'! categoryNames | aSet | aSet := Set new. DictionaryOfPreferences do: [:aPreference | aSet addAll: (aPreference categoryList collect: [:aCategory | aCategory asSymbol])]. ^aSet.! ! !Preferences class methodsFor: 'preferences panel' stamp: 'hpt 9/26/2004 16:54'! initializePreferencePanel: aPanel in: aPasteUpMorph "Initialize the given Preferences panel. in the given pasteup, which is the top-level panel installed in the container window. Also used to reset it after some change requires reformulation" | tabbedPalette controlPage aColor aFont maxEntriesPerCategory tabsMorph anExtent prefObjects cc | aPasteUpMorph removeAllMorphs. aFont := StrikeFont familyName: 'NewYork' size: 19. aColor := aPanel defaultBackgroundColor. tabbedPalette := TabbedPalette newSticky. tabbedPalette dropEnabled: false. (tabsMorph := tabbedPalette tabsMorph) color: aColor darker; highlightColor: Color red regularColor: Color brown darker darker. tabbedPalette on: #mouseDown send: #yourself to: #(). maxEntriesPerCategory := 0. self listOfCategories do: [:aCat | controlPage := AlignmentMorph newColumn beSticky color: aColor. controlPage on: #mouseDown send: #yourself to: #(). controlPage dropEnabled: false. Preferences alternativeWindowLook ifTrue: [cc := Color transparent. controlPage color: cc]. controlPage borderColor: aColor; layoutInset: 4. (prefObjects := self preferenceObjectsInCategory: aCat) do: [:aPreference | | button | button _ aPreference representativeButtonWithColor: cc inPanel: aPanel. button ifNotNil: [controlPage addMorphBack: button]]. controlPage setNameTo: aCat asString. aCat = #? ifTrue: [aPanel addHelpItemsTo: controlPage]. tabbedPalette addTabFor: controlPage font: aFont. aCat = 'search results' ifTrue: [(tabbedPalette tabNamed: aCat) setBalloonText: 'Use the ? category to find preferences by keyword; the results of your search will show up here']. maxEntriesPerCategory := maxEntriesPerCategory max: prefObjects size]. tabbedPalette selectTabNamed: '?'. tabsMorph rowsNoWiderThan: aPasteUpMorph width. aPasteUpMorph on: #mouseDown send: #yourself to: #(). anExtent := aPasteUpMorph width @ (490 max: (25 + tabsMorph height + (20 * maxEntriesPerCategory))). aPasteUpMorph extent: anExtent. aPasteUpMorph color: aColor. aPasteUpMorph addMorphBack: tabbedPalette.! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 4/11/2001 23:55'! inspectPreferences "Open a window on the current preferences dictionary, allowing the user to inspect and change the current preference settings. This is fallen back upon if Morphic is not present" "Preferences inspectPreferences" DictionaryOfPreferences inspectWithLabel: 'Preferences' ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'hpt 9/25/2004 11:49'! listOfCategories "Answer a list of category names for the preferences panel" ^ {#?}, self categoryNames asSortedArray, {#'search results'} "Preferences listOfCategories" ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 2/7/2001 15:02'! openFactoredPanel "Open up a tabbed Preferences panel. In mvc, a new one is launched on each request; in Morphic, any existing one is opened, and a new one launched only if no existing one can be found." Smalltalk isMorphic ifTrue: "reuse an existing one if one is found, else create a fresh one" [self currentWorld findAPreferencesPanel: nil] ifFalse: "in mvc, always opens a new one for now" [self openNewPreferencesPanel] "Preferences openFactoredPanel" ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 2/18/2001 01:45'! openFactoredPanelWithWidth: aWidth "Open up a preferences panel of the given width" "Preferences openFactoredPanelWithWidth: 325" | window playfield aPanel | aPanel _ PreferencesPanel new. playfield _ PasteUpMorph new width: aWidth. playfield dropEnabled: false. self initializePreferencePanel: aPanel in: playfield. self couldOpenInMorphic ifTrue: [window _ (SystemWindow labelled: 'Preferences') model: aPanel. window on: #keyStroke send: #keyStroke: to: aPanel. window bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)). window addMorph: playfield frame: (0 @ 0 extent: 1 @ 1). window updatePaneColors. window setProperty: #minimumExtent toValue: playfield extent + (12@15). self currentWorld addMorphFront: window. window center: self currentWorld center. window activateAndForceLabelToShow] ifFalse: [(window _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: playfield. MorphWorldView openOn: window label: 'Preferences' extent: playfield extent]! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 8/19/2001 08:19'! openNewPreferencesPanel "Create and open a new Preferences Panel" self openFactoredPanelWithWidth: 370 "Preferences openNewPreferencesPanel"! ! !Preferences class methodsFor: 'preferences panel' stamp: 'nb 6/17/2003 12:25'! openPreferencesControlPanel "Open a preferences panel" "Preferences openPreferencesControlPanel" Smalltalk verifyMorphicAvailability ifFalse: [^ Beeper beep]. ^ self openFactoredPanel! ! !Preferences class methodsFor: 'preferences panel' stamp: 'hpt 9/26/2004 15:54'! preferenceObjectsInCategory: aCategorySymbol "Answer a list of Preference objects that reside in the given category, in alphabetical order" ^ (DictionaryOfPreferences select: [:aPreference | aPreference categoryList includes: aCategorySymbol]) asSortedCollection: [:pref1 :pref2 | (pref1 viewRegistry viewOrder < pref2 viewRegistry viewOrder) or: [(pref1 viewRegistry viewOrder = pref2 viewRegistry viewOrder) & (pref1 name < pref2 name)]]! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 7/23/2002 16:10'! preferencesControlPanel "Answer a Preferences control panel window" "Preferences preferencesControlPanel openInHand" | window playfield aPanel | aPanel _ PreferencesPanel new. playfield _ PasteUpMorph new width: 325. playfield dropEnabled: false. window _ (SystemWindow labelled: 'Preferences') model: aPanel. self initializePreferencePanel: aPanel in: playfield. window on: #keyStroke send: #keyStroke: to: aPanel. window bounds: (100 @ 100 - (0 @ window labelHeight + window borderWidth) extent: playfield extent + (2 * window borderWidth)). window addMorph: playfield frame: (0 @ 0 extent: 1 @ 1). window updatePaneColors. window setProperty: #minimumExtent toValue: playfield extent + (12@15). ^ window! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:17'! annotationPanesChanged "The setting of the annotationPanes preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary"! ! !Preferences class methodsFor: 'reacting to change' stamp: 'tk 7/18/2001 16:02'! classicTilesSettingToggled "The current value of the largeTiles flag has changed; now react" Smalltalk isMorphic ifTrue: [Preferences universalTiles ifFalse: [self inform: 'note that this will only have a noticeable effect if the universalTiles preference is set to true, which it currently is not'] ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:31'! eToyFriendlyChanged "The eToyFriendly preference changed; React" ScriptingSystem customizeForEToyUsers: Preferences eToyFriendly! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:32'! infiniteUndoChanged "The infiniteUndo preference changed; react" self infiniteUndo ifFalse: [CommandHistory resetAllHistory]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 3/5/2001 13:20'! largeTilesSettingToggled "The current value of the largeTiles flag has changed; now react" Smalltalk isMorphic ifTrue: [Preferences universalTiles ifFalse: [self inform: 'note that this will only have a noticeable effect if the universalTiles preference is set to true, which it currently is not'] ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'mir 9/12/2001 15:15'! mouseOverHalosChanged World wantsMouseOverHalos: self mouseOverHalos! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 6/12/2001 20:18'! optionalButtonsChanged "The setting of the optionalButtons preference changed; react. Formerly, we replaced prototypes in flaps but this is no longer necessary" ! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:11'! roundedWindowCornersChanged "The user changed the value of the roundedWindowCorners preference. React" ActiveWorld fullRepaintNeeded! ! !Preferences class methodsFor: 'reacting to change' stamp: 'tk 7/18/2001 16:03'! setNotificationParametersForStandardPreferences "Set up the notification parameters for the standard preferences that require need them. When adding new Preferences that require use of the notification mechanism, users declare the notifcation info as part of the call that adds the preference, or afterwards -- the two relevant methods for doing that are: Preferences.addPreference:categories:default:balloonHelp:projectLocal:changeInformee:changeSelector: and Preference changeInformee:changeSelector:" "Preferences setNotificationParametersForStandardPreferences" | aPreference | #( (annotationPanes annotationPanesChanged) (eToyFriendly eToyFriendlyChanged) (infiniteUndo infiniteUndoChanged) (uniTilesClassic classicTilesSettingToggled) (optionalButtons optionalButtonsChanged) (roundedWindowCorners roundedWindowCornersChanged) (showProjectNavigator showProjectNavigatorChanged) (smartUpdating smartUpdatingChanged) (universalTiles universalTilesSettingToggled) (showSharedFlaps sharedFlapsSettingChanged)) do: [:pair | aPreference _ self preferenceAt: pair first. aPreference changeInformee: self changeSelector: pair second]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/30/2001 20:39'! sharedFlapsSettingChanged "The current value of the showSharedFlaps flag has changed; now react" self showSharedFlaps "viz. the new setting" ifFalse: [Flaps globalFlapTabsIfAny do: [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]] ifTrue: [Smalltalk isMorphic ifTrue: [self currentWorld addGlobalFlaps]]! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:33'! showProjectNavigatorChanged "The showProjectNavigatorChanged preference changed; react" Project current assureNavigatorPresenceMatchesPreference! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/12/2001 01:30'! smartUpdatingChanged "The smartUpdating preference changed. React" SystemWindow allSubInstancesDo: [:aWindow | aWindow amendSteppingStatus] "NOTE: This makes this preference always behave like a global preference, which is problematical"! ! !Preferences class methodsFor: 'reacting to change' stamp: 'sw 4/13/2001 11:22'! universalTilesSettingToggled "The current value of the universalTiles flag has changed; now react" (self preferenceAt: #universalTiles ifAbsent: [^ self]) localToProject ifFalse: [^ self inform: 'This is troubling -- you may regret having done that, because the change will apply to *all projects*, including pre-existing ones. Unfortunately this check is done after the damage is done, so you may be hosed. Fortunately, however, you can simply reverse your choice right now and perhaps no deep damage will have been done.']. self universalTiles "User just switched project to classic tiles" ifFalse: [self inform: 'CAUTION -- if you had any scripted objects in this project that already used universal tiles, there is no reasonable way to go back to classic tiles. Recommended course of action in that case: just toggle this preference right back to true.'] ifTrue: [Preferences capitalizedReferences ifFalse: [Preferences enable: #capitalizedReferences. self inform: 'Note that the "capitalizedReferences" flag has now been automatically set to true for you, since this is required for the use of universal tiles.']. World isMorph ifTrue: [World recreateScripts]]! ! !Preferences class methodsFor: 'scrollbar parameters' stamp: 'dgd 3/25/2003 19:58'! fontFactor "answer the convertion factor for resizing element based on font size" | factor | factor := TextStyle defaultFont height / 12.0. ^ factor > 1.0 ifTrue: [1 + (factor - 1.0 * 0.5)] ifFalse: [factor]! ! !Preferences class methodsFor: 'standard queries' stamp: 'dgd 3/21/2003 19:23'! alternativeWindowBoxesLook ^ self valueOfFlag: #alternativeWindowBoxesLook ifAbsent: [true]! ! !Preferences class methodsFor: 'standard queries' stamp: 'mir 3/5/2004 19:22'! debugLogTimestamp ^ self valueOfFlag: #debugLogTimestamp ifAbsent: [false]! ! !Preferences class methodsFor: 'standard queries' stamp: 'mir 6/7/2002 17:10'! fenceSoundEnabled: aBoolean self setPreference: #fenceSoundEnabled toValue: aBoolean! ! !Preferences class methodsFor: 'standard queries' stamp: 'mir 11/10/2003 14:28'! standaloneSecurityChecksEnabled ^ self valueOfFlag: #standaloneSecurityChecksEnabled ifAbsent: [false]! ! !Preferences class methodsFor: 'standard queries'! useFormsInPaintBox ^ self valueOfFlag: #useFormsInPaintBox ifAbsent: [false]! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 12/7/2001 00:44'! chooseKeyboardFocusColor "Let the user indicate what color he wishes to have used for keyboard-focus feedback" ColorPickerMorph new choseModalityFromPreference; sourceHand: self currentHand; target: self; selector: #keyboardFocusColor:; originalColor: self keyboardFocusColor; putUpFor: self currentHand near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'text highlighting' stamp: 'dew 1/8/2002 01:07'! keyboardFocusColor "Answer the keyboard focus color, initializing it if necessary" ^ Parameters at: #keyboardFocusColor ifAbsentPut: [Color lightGray] " Parameters removeKey: #keyboardFocusColor. Preferences keyboardFocusColor "! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 12/7/2001 00:44'! keyboardFocusColor: aColor "Set the keyboard focus color" Parameters at: #keyboardFocusColor put: aColor! ! !Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 07:02'! brightSqueak "The classic bright Squeak look. Windows have saturated colors and relatively low contrast; scroll-bars are of the flop-out variety and are on the left. Many power-user features are enabled." self setPreferencesFrom: #( (alternativeScrollbarLook false) (alternativeWindowLook false) (annotationPanes true) (automaticFlapLayout true) (balloonHelpEnabled true) (balloonHelpInMessageLists false) (browseWithDragNDrop true) (browseWithPrettyPrint false) (browserShowsPackagePane false) (classicNavigatorEnabled false) (classicNewMorphMenu false) (clickOnLabelToEdit false) (cmdDotEnabled true) (collapseWindowsInPlace false) (colorWhenPrettyPrinting false) (debugHaloHandle true) (debugPrintSpaceLog false) (debugShowDamage false) (decorateBrowserButtons true) (diffsInChangeList true) (diffsWithPrettyPrint false) (dragNDropWithAnimation true) (eToyFriendly false) (fastDragWindowForMorphic true) (fullScreenLeavesDeskMargins true) (haloTransitions false) (hiddenScrollBars false) (ignoreStyleIfOnlyBold true) (inboardScrollbars false) (logDebuggerStackToFile true) (magicHalos false) (menuButtonInToolPane false) (menuColorFromWorld false) (menuKeyboardControl true) (mouseOverForKeyboardFocus true) (navigatorOnLeftEdge true) (noviceMode false) (optionalButtons true) (personalizedWorldMenu true) (preserveTrash true) (printAlternateSyntax false) (projectViewsInWindows true) (projectZoom true) (propertySheetFromHalo false) (restartAlsoProceeds false) (reverseWindowStagger true) (roundedMenuCorners true) (roundedWindowCorners true) (scrollBarsNarrow false) (scrollBarsOnRight false) (scrollBarsWithoutMenuButton false) (selectiveHalos false) (showProjectNavigator false) (showSharedFlaps true) (simpleMenus false) (smartUpdating true) (systemWindowEmbedOK false) (thoroughSenders true) (timeStampsInMenuTitles true) (universalTiles false) (unlimitedPaintArea false) (useButtonProprtiesToFire false) (useUndo true) (viewersInFlaps true) (warnIfNoChangesFile true) (warnIfNoSourcesFile true)). self installBrightWindowColors! ! !Preferences class methodsFor: 'themes' stamp: 'ka 6/30/2002 13:53'! keihanna "Settings more similar to those found in a standard browser-plug-in-based Squeak image than westwood" self setPreferencesFrom: #( (alternativeScrollbarLook true) (alternativeWindowLook true) (classicNavigatorEnabled true) (eToyFriendly true) (haloTransitions true) (honorDesktopCmdKeys false) (includeSoundControlInNavigator true) (magicHalos true) (menuKeyboardControl false) (mouseOverHalos true) (preserveTrash true) (projectViewsInWindows false) (propertySheetFromHalo true) (showDirectionHandles true) (soundStopWhenDone true) (unlimitedPaintArea true) (uniqueNamesInHalos true) (uniTilesClassic false))! ! !Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 07:27'! magdeburg "Alternative window & scroll-bar looks, no desktop command keys, no keyboard menu control, no annotation panes..." self setPreferencesFrom: #( (alternativeScrollbarLook true) (alternativeWindowLook true) (annotationPanes false) (browseWithDragNDrop true) (canRecordWhilePlaying false) (classicNavigatorEnabled true) (conversionMethodsAtFileOut true) (dragNDropWithAnimation true) (haloTransitions true) (honorDesktopCmdKeys false) (magicHalos true) (menuKeyboardControl false) (scrollBarsWithoutMenuButton true)). self installBrightWindowColors! ! !Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 07:37'! outOfTheBox "The default out-of-the-box preference settings for Squeak 3.2. The 'alternative' window-look and scrollbar-look are used. Button panes are used but not annotation panes. Scrollbars are on the right and do not flop out." self setPreferencesFrom: self defaultValueTableForCurrentRelease! ! !Preferences class methodsFor: 'themes' stamp: 'sw 10/26/2002 01:37'! paloAlto "Similar to the brightSqueak theme, but with a number of idiosyncratic personal settings. Note that mouseOverForKeyboardFocus & caseSensitiveFinds are both true" self setPreferencesFrom: #( (abbreviatedBrowserButtons false) (accessOnlineModuleRepositories noOpinion) (allowCelesteTell noOpinion) (alternativeBrowseIt noOpinion) (alternativeScrollbarLook false) (alternativeWindowLook false) (annotationPanes true) (areaFillsAreTolerant true) (areaFillsAreVeryTolerant false) (autoAccessors false) (automaticFlapLayout true) (automaticKeyGeneration noOpinion) (automaticPlatformSettings noOpinion) (automaticViewerPlacement false) (balloonHelpEnabled true) (balloonHelpInMessageLists false) (batchPenTrails noOpinion) (browseWithDragNDrop false) (browseWithPrettyPrint false) (browserShowsPackagePane false) (canRecordWhilePlaying noOpinion) (capitalizedReferences true) (caseSensitiveFinds true) (cautionBeforeClosing false) (celesteHasStatusPane noOpinion) (celesteShowsAttachmentsFlag noOpinion) (changeSetVersionNumbers true) (checkForSlips true) (checkForUnsavedProjects noOpinion) (classicNavigatorEnabled false) (classicNewMorphMenu false) (clickOnLabelToEdit false) (cmdDotEnabled true) (collapseWindowsInPlace false) (colorWhenPrettyPrinting false) (compactViewerFlaps false) (compressFlashImages noOpinion) (confirmFirstUseOfStyle true) (conservativeModuleDeActivation noOpinion) (conversionMethodsAtFileOut true) (cpuWatcherEnabled noOpinion) (debugHaloHandle true) (debugPrintSpaceLog true) (debugShowDamage false) (decorateBrowserButtons true) (diffsInChangeList true) (diffsWithPrettyPrint false) (dismissAllOnOptionClose true) (dragNDropWithAnimation false) (duplicateControlAndAltKeys false) (eToyFriendly false) (eToyLoginEnabled noOpinion) (enableLocalSave true) (extractFlashInHighQuality noOpinion) (extractFlashInHighestQuality noOpinion) (extraDebuggerButtons true) (fastDragWindowForMorphic true) (fenceEnabled true) (fenceSoundEnabled false) (fullScreenLeavesDeskMargins true) (haloTransitions false) (hiddenScrollBars false) (higherPerformance noOpinion) (honorDesktopCmdKeys true) (ignoreStyleIfOnlyBold true) (inboardScrollbars false) (includeSoundControlInNavigator true) (infiniteUndo false) (lenientScopeForGlobals noOpinion) (logDebuggerStackToFile true) (magicHalos false) (menuButtonInToolPane false) (menuColorFromWorld false) (menuKeyboardControl true) (modalColorPickers true) (modularClassDefinitions noOpinion) (mouseOverForKeyboardFocus true) (mouseOverHalos false) (mvcProjectsAllowed true) (navigatorOnLeftEdge true) (noviceMode false) (okToReinitializeFlaps true) (optionalButtons true) (passwordsOnPublish noOpinion) (personalizedWorldMenu true) (postscriptStoredAsEPS noOpinion) (preserveTrash false) (projectsSentToDisk noOpinion) (projectViewsInWindows true) (projectZoom true) (promptForUpdateServer false) (printAlternateSyntax false) (propertySheetFromHalo false) (restartAlsoProceeds false) (reverseWindowStagger true) (roundedMenuCorners true) (roundedWindowCorners true) (scrollBarsNarrow false) (scrollBarsOnRight false) (scrollBarsWithoutMenuButton false) (securityChecksEnabled noOpinion) (selectiveHalos false) (showBoundsInHalo false) (showDirectionForSketches true) (showDirectionHandles false) (showFlapsWhenPublishing false) (showProjectNavigator false) (showSecurityStatus noOpinion) (showSharedFlaps true) (signProjectFiles noOpinion) (simpleMenus false) (slideDismissalsToTrash true) (smartUpdating true) (soundQuickStart noOpinion) (soundsEnabled true) (soundStopWhenDone noOpinion) (startInUntrustedDirectory noOpinion) (strongModules noOpinion) (swapControlAndAltKeys noOpinion) (swapMouseButtons noOpinion) (systemWindowEmbedOK false) (thoroughSenders true) (tileTranslucentDrag noOpinion) (timeStampsInMenuTitles true) (turnOffPowerManager noOpinion) (twentyFourHourFileStamps false) (twoSidedPoohTextures noOpinion) (typeCheckingInTileScripting noOpinion) (uniqueNamesInHalos false) (uniTilesClassic noOpinion) (universalTiles false) (unlimitedPaintArea false) (updateSavesFile noOpinion) (useButtonProprtiesToFire false) (useUndo true) (viewersInFlaps true) (warnAboutInsecureContent noOpinion) (warnIfNoChangesFile true) (warnIfNoSourcesFile true)). self installBrightWindowColors! ! !Preferences class methodsFor: 'themes' stamp: 'sw 5/2/2002 10:45'! personal "Settings saved (by sometime earlier having hit the 'Save Current Settings as my Personal Preferences' in a Preferences panel) as my personal preferences" self restorePersonalPreferences! ! !Preferences class methodsFor: 'themes' stamp: 'sw 4/21/2002 06:15'! smalltalk80 "A traditional monochrome Smalltalk-80 look and feel, clean and austere, and lacking many features added to Squeak in recent years. Caution: this theme removes the standard Squeak flaps, turns off the 'smartUpdating' feature that keeps multiple browsers in synch, and much more." self setPreferencesFrom: #( (alternativeScrollbarLook false) (alternativeWindowLook false) (annotationPanes false) (autoAccessors false) (balloonHelpEnabled false) (balloonHelpInMessageLists false) (batchPenTrails noOpinion) (browseWithDragNDrop false) (browseWithPrettyPrint false) (browserShowsPackagePane false) (caseSensitiveFinds true) (checkForSlips false) (classicNavigatorEnabled false) (clickOnLabelToEdit true) (cmdDotEnabled true) (collapseWindowsInPlace false) (colorWhenPrettyPrinting false) (diffsInChangeList false) (diffsWithPrettyPrint false) (dragNDropWithAnimation false) (eToyFriendly false) (fastDragWindowForMorphic true) (fenceEnabled noOpinion) (honorDesktopCmdKeys false) (ignoreStyleIfOnlyBold true) (inboardScrollbars false) (menuColorFromWorld false) (menuKeyboardControl false) (mouseOverForKeyboardFocus true) (mvcProjectsAllowed true) (noviceMode false) (okToReinitializeFlaps true) (optionalButtons false) (personalizedWorldMenu false) (printAlternateSyntax false) (projectViewsInWindows true) (projectZoom true) (restartAlsoProceeds false) (roundedMenuCorners false) (roundedWindowCorners false) (scrollBarsNarrow false) (scrollBarsOnRight false) (scrollBarsWithoutMenuButton false) (securityChecksEnabled noOpinion) (showProjectNavigator false) (showSharedFlaps false) (simpleMenus false) (smartUpdating false) (thoroughSenders false) (timeStampsInMenuTitles false)). self installUniformWindowColors! ! !Preferences class methodsFor: 'themes' stamp: 'tak 12/8/2004 18:51'! takanawa self setPreferencesFrom: #( (alternativeScrollbarLook true) (alternativeWindowLook true) (canRecordWhilePlaying true) (classicNavigatorEnabled false) (eToyFriendly true) (haloTransitions true) (honorDesktopCmdKeys false) (includeSoundControlInNavigator true) (magicHalos true) (menuKeyboardControl false) (mouseOverHalos true) (preserveTrash true) (projectViewsInWindows true) (propertySheetFromHalo true) (showDirectionHandles true) (showProjectNavigator true) (soundQuickStart true) (soundStopWhenDone true) (uniTilesClassic false) (uniqueNamesInHalos true) (unlimitedPaintArea true) )! ! !Preferences class methodsFor: 'themes' stamp: 'sw 5/2/2002 11:03'! westwood "Settings generally similar to those found in a standard browser-plug-in-based Squeak image" self setPreferencesFrom: #( (alternativeScrollbarLook true) (alternativeWindowLook true) (classicNavigatorEnabled true) (eToyFriendly true) (haloTransitions true) (honorDesktopCmdKeys false) (magicHalos true) (menuKeyboardControl false) (preserveTrash true) (propertySheetFromHalo true) (unlimitedPaintArea true))! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 9/28/2001 08:53'! darkenStandardWindowPreferences "Make all window-color preferences one shade darker" | windowColorDict | windowColorDict _ self parameterAt: #windowColors ifAbsentPut: [IdentityDictionary new]. windowColorDict associationsDo: [:assoc | windowColorDict at: assoc key put: assoc value darker] "Preferences darkenStandardWindowPreferences" ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:56'! installBrightWindowColors "Install the factory-provided default window colors for all tools" "Preferences installBrightWindowColors" self installWindowColorsVia: [:aSpec | aSpec brightColor]! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:51'! installMissingWindowColors "Install the factory-provided bright window colors for tools not yet in the dictionary -- a one-time bootstrap" "Preferences installMissingWindowColors" | windowColorDict | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new]. windowColorDict _ Parameters at: #windowColors. self windowColorTable do: [:colorSpec | (windowColorDict includesKey: colorSpec classSymbol) ifFalse: [windowColorDict at: colorSpec classSymbol put: (Color colorFrom: colorSpec brightColor)]]! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:55'! installPastelWindowColors "Install the factory-provided default pastel window colors for all tools" "Preferences installBrightWindowColors" self installWindowColorsVia: [:aSpec | aSpec pastelColor]! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 12:55'! installUniformWindowColors "Install the factory-provided uniform window colors for all tools" "Preferences installUniformWindowColors" self installWindowColorsVia: [:aQuad | #white]! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 13:59'! installWindowColorsVia: colorSpecBlock "Install windows colors using colorSpecBlock to deliver the color source for each element; the block is handed a WindowColorSpec object" "Preferences installBrightWindowColors" | windowColorDict | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new]. windowColorDict _ Parameters at: #windowColors. self windowColorTable do: [:aColorSpec | windowColorDict at: aColorSpec classSymbol put: (Color colorFrom: (colorSpecBlock value: aColorSpec))]! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 9/28/2001 09:12'! lightenStandardWindowPreferences "Make all window-color preferences one shade darker" | windowColorDict | windowColorDict _ self parameterAt: #windowColors ifAbsentPut: [IdentityDictionary new]. windowColorDict associationsDo: [:assoc | windowColorDict at: assoc key put: assoc value lighter] "Preferences lightenStandardWindowPreferences" ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 4/21/2002 02:55'! windowColorHelp "Provide help for the window-color panel" | helpString | helpString _ 'The "Window Colors" panel lets you select colors for many kinds of standard Squeak windows. You can change your color preference for any particular tool by clicking on the color swatch and then selecting the desired color from the resulting color-picker. The three buttons entitled "Bright", "Pastel", and "White" let you revert to any of three different standard color schemes. The choices you make in the Window Colors panel only affect the colors of new windows that you open. You can make other tools have their colors governed by this panel by simply implementing #windowColorSpecification on the class side of the model -- consult implementors of that method to see examples of how to do this.'. (StringHolder new contents: helpString) openLabel: 'About Window Colors' "Preferences windowColorHelp"! ! !Preferences class methodsFor: 'window colors' stamp: 'dvf 8/23/2003 12:18'! windowColorTable "Answer a list of WindowColorSpec objects, one for each tool to be represented in the window-color panel" ^ (((self systemNavigation allClassesImplementing: #windowColorSpecification) collect: [:aClass | aClass theNonMetaClass windowColorSpecification]) asSortedCollection: [:specOne :specTwo | specOne wording < specTwo wording]) asArray "Preferences windowColorTable"! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 2/26/2002 14:15'! windowSpecificationPanel "Put up a panel for specifying window colors" "Preferences windowSpecificationPanel" | aPanel buttonRow aButton aRow aSwatch aColor aWindow aMiniWorld aStringMorph | aPanel _ AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap; layoutInset: 0. aPanel addMorph: (buttonRow _ AlignmentMorph newRow color: (aColor _ Color tan lighter)). buttonRow addTransparentSpacerOfSize: 2@0. buttonRow addMorphBack: (SimpleButtonMorph new label: '?'; target: self; actionSelector: #windowColorHelp; setBalloonText: 'Click for an explanation of this panel'; color: Color veryVeryLightGray; yourself). buttonRow addTransparentSpacerOfSize: 8@0. #( ('Bright' installBrightWindowColors yellow 'Use standard bright colors for all windows.') ('Pastel' installPastelWindowColors paleMagenta 'Use standard pastel colors for all windows.') ('White' installUniformWindowColors white 'Use white backgrounds for all standard windows.')) do: [:quad | aButton _ (SimpleButtonMorph new target: self) label: quad first; actionSelector: quad second; color: (Color colorFrom: quad third); setBalloonText: quad fourth; yourself. buttonRow addMorphBack: aButton. buttonRow addTransparentSpacerOfSize: 10@0]. self windowColorTable do: [:colorSpec | aRow _ AlignmentMorph newRow color: aColor. aSwatch _ ColorSwatch new target: self; getSelector: #windowColorFor:; putSelector: #setWindowColorFor:to:; argument: colorSpec classSymbol; extent: (40 @ 20); setBalloonText: 'Click here to change the standard color to be used for ', colorSpec wording, ' windows.'; yourself. aRow addMorphFront: aSwatch. aRow addTransparentSpacerOfSize: (12 @ 1). aRow addMorphBack: (aStringMorph _ StringMorph contents: colorSpec wording font: TextStyle defaultFont). aStringMorph setBalloonText: colorSpec helpMessage. aPanel addMorphBack: aRow]. Smalltalk isMorphic ifTrue: [aWindow _ aPanel wrappedInWindowWithTitle: 'Window Colors'. " don't allow the window to be picked up by clicking inside " aPanel on: #mouseDown send: #yourself to: aPanel. self currentWorld addMorphCentered: aWindow. aWindow activateAndForceLabelToShow ] ifFalse: [(aMiniWorld _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aPanel. aMiniWorld startSteppingSubmorphsOf: aPanel. MorphWorldView openOn: aMiniWorld label: 'Window Colors' extent: aMiniWorld fullBounds extent]! ! !Preferences class methodsFor: 'paintbox' stamp: 'yo 1/13/2005 11:05'! useFormsInPaintBox: aBoolean self setPreference: #useFormsInPaintBox toValue: aBoolean ! ! !Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:18'! initialize self registerInFlapsRegistry. ! ! !Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:20'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(Preferences preferencesControlPanel 'Preferences' 'Allows you to control numerous options') forFlapNamed: 'Tools'. cl registerQuad: #(Preferences annotationEditingWindow 'Annotations' 'Allows you to specify the annotations to be shown in the annotation panes of browsers, etc.') forFlapNamed: 'Tools'.]! ! !Preferences class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:38'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Preferences class methodsFor: '*customevents-preferences' stamp: 'nk 8/18/2004 18:01'! allowEtoyUserCustomEvents ^ (self valueOfFlag: #allowEtoyUserCustomEvents ifAbsent: [false]) and: [ self eToyFriendly not ]! ! !PreferencesPanel methodsFor: 'initialization' stamp: 'sw 2/6/2001 02:13'! addModelItemsToWindowMenu: aMenu "aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic SystemWindow. Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself." true ifTrue: [^ self]. "The below are provisionally disenfranchised, because their function is now directly available in the ? category" aMenu addLine. aMenu add: 'find preference... (f)' target: self action: #findPreference:. aMenu add: 'inspect parameters' target: Preferences action: #inspectParameters! ! !PreferencesPanel methodsFor: 'initialization' stamp: 'sw 4/13/2001 11:26'! adjustProjectLocalEmphasisFor: aSymbol "Somewhere, the preference represented by aSymbol got changed from being one that is truly global to one that varies by project, or vice-versa. Get my panel right -- this involves changing the emphasis on the item" | aWindow toFixUp allMorphs emphasis | (aWindow _ self containingWindow) ifNil: [^ self]. emphasis _ (Preferences preferenceAt: aSymbol ifAbsent: [^ self]) localToProject ifTrue: [1 "bold for local-to-project"] ifFalse: [0 "plain for global"]. allMorphs _ IdentitySet new. aWindow allMorphsAndBookPagesInto: allMorphs. toFixUp _ allMorphs select: [:m | (m isKindOf: StringMorph) and: [m contents = aSymbol]]. toFixUp do: [:aStringMorph | aStringMorph emphasis: emphasis] ! ! !PreferencesPanel methodsFor: 'initialization' stamp: 'hpt 9/26/2004 16:55'! findPreferencesMatching: incomingTextOrString "find all preferences matching incomingTextOrString" | result aList aPalette controlPage cc | result := incomingTextOrString asString asLowercase. result := result asLowercase withBlanksTrimmed. result isEmptyOrNil ifTrue: [^ self]. aList := Preferences allPreferenceObjects select: [:aPreference | (aPreference name includesSubstring: result caseSensitive: false) or: [aPreference helpString includesSubstring: result caseSensitive: false]]. aPalette := (self containingWindow ifNil: [^ self]) findDeeplyA: TabbedPalette. aPalette ifNil: [^ self]. aPalette selectTabNamed: 'search results'. aPalette currentPage ifNil: [^ self]. "bkwd compat" controlPage := aPalette currentPage. controlPage removeAllMorphs. controlPage addMorph: (StringMorph contents: ('Preferences matching "', self searchString, '"') font: Preferences standardButtonFont). Preferences alternativeWindowLook ifTrue:[ cc := Color transparent. controlPage color: cc]. aList := aList asSortedCollection: [:a :b | a name < b name]. aList do: [:aPreference | | button | button _ aPreference representativeButtonWithColor: cc inPanel: self. button ifNotNil: [controlPage addMorphBack: button]]. aPalette world startSteppingSubmorphsOf: aPalette! ! !PreferencesPanel methodsFor: 'category switch' stamp: 'sw 2/18/2001 04:02'! switchToCategoryNamed: aName event: anEvent "Switch the panel so that it looks at the category of the given name" | aPalette | aPalette _ self containingWindow findDeeplyA: TabbedPalette. aPalette ifNil: [^ self]. aPalette selectTabNamed: aName! ! !PreferencesPanel methodsFor: 'find' stamp: 'nk 4/28/2004 10:18'! addHelpItemsTo: panelPage "Add the items appropriate the the ? page of the receiver" | aButton aTextMorph aMorph firstTextMorph | panelPage hResizing: #shrinkWrap; vResizing: #shrinkWrap. firstTextMorph _ TextMorph new contents: 'Search Preferences for:'. firstTextMorph beAllFont: ((TextStyle default fontOfSize: 13) emphasized: 1). panelPage addMorphBack: firstTextMorph lock. panelPage addTransparentSpacerOfSize: 0@10. aMorph _ RectangleMorph new clipSubmorphs: true; beTransparent; borderWidth: 2; borderColor: Color black; extent: 250 @ 36. aMorph vResizing: #rigid; hResizing: #rigid. aTextMorph _ PluggableTextMorph new on: self text: #searchString accept: #setSearchStringTo: readSelection: nil menu: nil. " aTextMorph hResizing: #rigid." aTextMorph borderWidth: 0. aTextMorph font: ((TextStyle default fontOfSize: 21) emphasized: 1); setTextColor: Color red. aMorph addMorphBack: aTextMorph. aTextMorph acceptOnCR: true. aTextMorph position: (aTextMorph position + (6@5)). aMorph clipLayoutCells: true. aTextMorph extent: 240 @ 25. panelPage addMorphBack: aMorph. aTextMorph setBalloonText: 'Type what you want to search for here, then hit the "Search" button, or else hit RETURN or ENTER'. aTextMorph setTextMorphToSelectAllOnMouseEnter. aTextMorph hideScrollBarsIndefinitely. panelPage addTransparentSpacerOfSize: 0@10. aButton _ SimpleButtonMorph new target: self; color: Color transparent; actionSelector: #initiateSearch:; arguments: {aTextMorph}; label: 'Search'. panelPage addMorphBack: aButton. aButton setBalloonText: 'Type what you want to search for in the box above, then click here (or hit RETURN or ENTER) to start the search; results will appear in the "search results" category.'. panelPage addTransparentSpacerOfSize: 0@30. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore all Default Preference Settings'; target: Preferences; actionSelector: #chooseInitialSettings; setBalloonText: 'Click here to reset all the preferences to their standard default values.'; yourself). panelPage addTransparentSpacerOfSize: 0@14. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Save Current Settings as my Personal Preferences'; target: Preferences; actionSelector: #savePersonalPreferences; setBalloonText: 'Click here to save the current constellation of Preferences settings as your personal defaults; you can get them all reinstalled with a single gesture by clicking the "Restore my Personal Preferences".'; yourself). panelPage addTransparentSpacerOfSize: 0@14. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore my Personal Preferences'; target: Preferences; actionSelector: #restorePersonalPreferences; setBalloonText: 'Click here to reset all the preferences to their values in your Personal Preferences.'; yourself). panelPage addTransparentSpacerOfSize: 0@30. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Save Current Settings to Disk'; target: Preferences; actionSelector: #storePreferencesToDisk; setBalloonText: 'Click here to save the current constellation of Preferences settings to a file; you can get them all reinstalled with a single gesture by clicking "Restore Settings From Disk".'; yourself). panelPage addTransparentSpacerOfSize: 0@14. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Restore Settings from Disk'; target: Preferences; actionSelector: #restorePreferencesFromDisk; setBalloonText: 'Click here to load all the preferences from their saved values on disk.'; yourself). panelPage addTransparentSpacerOfSize: 0@30. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Inspect Parameters'; target: Preferences; actionSelector: #inspectParameters; setBalloonText: 'Click here to view all the values stored in the system Parameters dictionary'; yourself). panelPage addTransparentSpacerOfSize: 0@10. panelPage addMorphBack: (Preferences themeChoiceButtonOfColor: Color transparent font: TextStyle defaultFont). panelPage addTransparentSpacerOfSize: 0@10. panelPage addMorphBack: (SimpleButtonMorph new color: Color transparent; label: 'Help!!'; target: Preferences; actionSelector: #giveHelpWithPreferences; setBalloonText: 'Click here to get some hints on use of this Preferences Panel'; yourself). panelPage wrapCentering: #center. ! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 8/6/2001 12:09'! containingWindow "Answer the window in which the receiver is seen" ^ super containingWindow ifNil: [Smalltalk isMorphic ifFalse: [self currentWorld]]! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 2/18/2001 04:03'! findCategoryFromPreference: prefSymbol "Find all categories in which the preference occurs" | aMenu| aMenu _ MenuMorph new defaultTarget: self. (Preferences categoriesContainingPreference: prefSymbol) do: [:aCategory | aMenu add: aCategory target: self selector: #switchToCategoryNamed:event: argumentList: {aCategory. MorphicEvent new}]. aMenu popUpInWorld! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 2/4/2001 03:31'! findPreference: evt "Allow the user to submit a selector fragment; search for that among preference names; put up a list of qualifying preferences; if the user selects one of those, redirect the preferences panel to reveal the chosen preference" self findPreferencesMatching: (FillInTheBlank request: 'Search for preferences containing:' initialAnswer: 'color')! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 02:01'! findPreferencesMatchingSearchString "find all preferences matching incomingTextOrString" self findPreferencesMatching: self searchString! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 7/27/2001 16:39'! initiateSearch: morphHoldingSearchString "Carry out the action of the Search button in the Preferences panel" searchString _ morphHoldingSearchString text. self setSearchStringTo: self searchString. self findPreferencesMatchingSearchString! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 02:06'! keyStroke: anEvent "Handle a keystroke event in the panel; we map f (for find) into a switch to the ? category" (anEvent keyCharacter == $f) ifTrue: [^ self switchToCategoryNamed: #? event: nil]! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 7/27/2001 23:11'! searchString "Answer the current searchString, initializing it if need be" | win aMorph | searchString isEmptyOrNil ifTrue: [searchString _ 'Type here, hit Search'. (win _ self containingWindow) ifNotNil: [aMorph _ win findDeepSubmorphThat: [:m | m isKindOf: PluggableTextMorph] ifAbsent: [^ searchString]. aMorph setText: searchString. aMorph setTextMorphToSelectAllOnMouseEnter. aMorph selectAll]]. ^ searchString! ! !PreferencesPanel methodsFor: 'find' stamp: 'sw 2/6/2001 01:45'! setSearchStringTo: aText "The user submitted aText as the search string; now search for it" searchString _ aText asString. self findPreferencesMatching: searchString. ^ true! ! !PreferencesPanel class methodsFor: 'cleanup' stamp: 'gm 2/22/2003 18:58'! deleteAllPreferencesPanels "Called manually to clobber all existing preferences panels" "PreferencesPanel deleteAllPreferencesPanels" | aWindow | self allInstancesDo: [:aPanel | (aWindow _ aPanel containingWindow) isMorph ifTrue: [aWindow delete]]. self killExistingMVCViews. UpdatingThreePhaseButtonMorph allInstancesDo: "clobber old stand-alone prefs buttons" [:m | (m actionSelector == #togglePreference:) ifTrue: [(m owner isAlignmentMorph) ifTrue: [m owner delete]]]! ! !PreferencesPanel class methodsFor: 'cleanup' stamp: 'RAA 4/14/2001 11:04'! isAPreferenceViewToKill: aSystemView "Answer whether the given StandardSystemView is one affiliated with a PreferencesPanel" | m target subView | aSystemView subViews size = 1 ifFalse: [^ false]. subView _ aSystemView subViews first. (subView isKindOf: MorphWorldView) ifFalse: [^ false]. ((m _ subView model) isKindOf: MVCWiWPasteUpMorph) ifFalse: [^ false]. m submorphs size = 1 ifFalse: [^ false]. m firstSubmorph submorphs size = 1 ifFalse: [^ false]. target _ m firstSubmorph firstSubmorph. (target isKindOf: TabbedPalette) ifFalse: [^ false]. ^ #(browsing debug fileout general halos) allSatisfy: [:s | (target tabNamed: s) notNil]! ! !PreferencesPanel class methodsFor: 'cleanup' stamp: 'RAA 4/14/2001 11:03'! killExistingMVCViews "Kill all existing preferences views in mvc" " PreferencesPanel killExistingMVCViews " | byebye | ControlManager allInstances do: [ :cm | byebye _ cm controllersSatisfying: [ :eachC | self isAPreferenceViewToKill: eachC view]. byebye do: [ :each | each status: #closed. each view release. cm unschedule: each]]! ! !PreferencesPanel class methodsFor: 'window color' stamp: 'sw 2/26/2002 14:41'! windowColorSpecification "Answer a WindowColorSpec object that declares my preference" ^ WindowColorSpec classSymbol: self name wording: 'Preferences Panel' brightColor: #(0.645 1.0 1.0) pastelColor: #(0.886 1.0 1.0) helpMessage: 'A tool for expressing personal preferences for numerous options.'! ! !Presenter methodsFor: 'misc' stamp: 'dgd 2/22/2003 19:08'! currentlyViewing: aPlayer "Only detects viewers in tabs" aPlayer ifNil: [^false]. ^aPlayer viewerFlapTab notNil! ! !Presenter methodsFor: 'misc' stamp: 'sw 8/28/2002 23:07'! drawingJustCompleted: aSketchMorph "The user just finished drawing. Now maybe put up a viewer" | aWorld | self flushPlayerListCache. "Because a new drawing already created one, thus obviating #assuredPlayer kicking in with its invalidation" aWorld _ associatedMorph world. (aWorld hasProperty: #automaticFlapViewing) ifTrue: [^ aWorld presenter viewMorph: aSketchMorph]. (aSketchMorph pasteUpMorph hasProperty: #automaticViewing) ifTrue: [self viewMorph: aSketchMorph]! ! !Presenter methodsFor: 'palette & parts bin' stamp: 'sw 2/12/2001 22:02'! systemQueryPhraseWithActionString: anActionString labelled: aLabel "Answer a SystemQueryPhrase with the given action string and label" | aTile aPhrase | aPhrase _ SystemQueryPhrase new. aTile _ BooleanTile new. aTile setExpression: anActionString label: aLabel. aPhrase addMorph: aTile. aPhrase enforceTileColorPolicy. ^ aPhrase! ! !Presenter methodsFor: 'playerList' stamp: 'yo 7/2/2004 19:45'! allKnownScriptSelectors "Answer a list of all the selectors implemented by any user-scripted objected within the scope of the receiver" | aSet allUniclasses | aSet _ Set with: ('script' translated , '1') asSymbol. allUniclasses _ (self presenter allPlayersWithUniclasses collect: [:aPlayer | aPlayer class]) asSet. allUniclasses do: [:aUniclass | aSet addAll: aUniclass namedTileScriptSelectors]. ^ aSet asSortedArray "ActiveWorld presenter allKnownScriptSelectors" ! ! !Presenter methodsFor: 'playerList' stamp: 'sw 12/19/2003 23:39'! allKnownUnaryScriptSelectors "Answer a list of all the unary selectors implemented by any user-scripted objected within the scope of the receiver; include #emptyScript as a bail-out" | aSet allUniclasses | aSet _ Set with: #emptyScript. allUniclasses _ (self allPlayersWithUniclasses collect: [:aPlayer | aPlayer class]) asSet. allUniclasses do: [:aUniclass | aSet addAll: aUniclass namedUnaryTileScriptSelectors]. ^ aSet asSortedArray "ActiveWorld presenter allKnownUnaryScriptSelectors" ! ! !Presenter methodsFor: 'playerList' stamp: 'sw 8/2/2004 17:24'! browseAllScriptsTextually "Open a method-list browser on all the scripts in the project" | aList aMethodList | (aList _ self uniclassesAndCounts) size == 0 ifTrue: [^ self inform: 'there are no scripted players']. aMethodList _ OrderedCollection new. aList do: [:aPair | aPair first addMethodReferencesTo: aMethodList]. aMethodList size > 0 ifFalse: [^ self inform: 'there are no scripts in this project!!']. SystemNavigation new browseMessageList: aMethodList name: 'All scripts in this project' autoSelect: nil " ActiveWorld presenter browseAllScriptsTextually "! ! !Presenter methodsFor: 'playerList' stamp: 'sw 3/8/2004 22:09'! hasAnyTextuallyCodedScripts "Answer whether any uniclasses in the receiver have any textually coded scripts" self uniclassesAndCounts do: [:classAndCount | classAndCount first scripts do: [:aScript | aScript isTextuallyCoded ifTrue: [^ true]]]. ^ false " ActiveWorld presenter hasAnyTextuallyCodedScripts "! ! !Presenter methodsFor: 'playerList' stamp: 'sw 11/14/2001 00:31'! reinvigorateAllScriptsTool: anAllScriptsTool "Rebuild the contents of an All Scripts tool" | showingOnlyActiveScripts candidateList firstTwo oldList allExtantPlayers newList morphList | showingOnlyActiveScripts _ anAllScriptsTool showingOnlyActiveScripts. self flushPlayerListCache. "needed? Probably to pick up on programmatical script-status control only" firstTwo _ {anAllScriptsTool submorphs first. anAllScriptsTool submorphs second}. oldList _ (anAllScriptsTool submorphs copyFrom: 3 to: anAllScriptsTool submorphs size) collect: [:aRow | (aRow findA: UpdatingSimpleButtonMorph) target]. allExtantPlayers _ self allExtantPlayers. anAllScriptsTool showingAllInstances "take all instances of all classes" ifTrue: [candidateList _ allExtantPlayers] ifFalse: "include only one exemplar per uniclass. Try to get one that has some qualifying scripts" [candidateList _ Set new. allExtantPlayers do: [:aPlayer | (candidateList detect: [:plyr | plyr isMemberOf: aPlayer class] ifNone: [nil]) ifNil: [aPlayer instantiatedUserScriptsDo: [:aScriptInstantiation | (showingOnlyActiveScripts not or: [aScriptInstantiation pausedOrTicking]) ifTrue: [candidateList add: aPlayer]]]]]. newList _ OrderedCollection new. candidateList do: [:aPlayer | aPlayer instantiatedUserScriptsDo: [:aScriptInstantiation | (showingOnlyActiveScripts not or: [aScriptInstantiation pausedOrTicking]) ifTrue: [newList add: aScriptInstantiation]]]. oldList asSet = newList asSet ifFalse: [anAllScriptsTool removeAllMorphs; addAllMorphs: firstTwo. morphList _ newList collect: [:aScriptInstantiation | aScriptInstantiation statusControlRowIn: anAllScriptsTool]. anAllScriptsTool addAllMorphs: morphList. newList do: [:aScriptInstantiation | aScriptInstantiation updateAllStatusMorphs]]! ! !Presenter methodsFor: 'playerList' stamp: 'sw 7/28/2004 21:00'! reinvigoratePlayersTool: aPlayersTool "Rebuild the contents of the Players tool" | firstTwo oldList newList rowsForPlayers | firstTwo _ {aPlayersTool submorphs first. aPlayersTool submorphs second}. oldList _ (aPlayersTool submorphs copyFrom: 3 to: aPlayersTool submorphs size) collect: [:aRow | aRow playerRepresented]. self flushPlayerListCache. newList _ self allExtantPlayers. oldList asSet = newList asSet ifFalse: [aPlayersTool removeAllMorphs; addAllMorphs: firstTwo. rowsForPlayers _ newList collect: [:aPlayer | aPlayer entryForPlayersTool: aPlayersTool]. aPlayersTool addAllMorphs: rowsForPlayers ]! ! !Presenter methodsFor: 'playerList' stamp: 'yo 2/10/2005 17:07'! reportPlayersAndScripts "Open a window which contains a report on players and their scripts" | aList aString | (aList _ self uniclassesAndCounts) ifEmpty: [^ self inform: 'there are no scripted players' translated]. aString _ String streamContents: [:aStream | aList do: [:aPair | aStream nextPutAll: aPair first name, ' -- ', aPair second printString. aStream nextPutAll: ' ', (aPair second > 1 ifTrue: ['instances'] ifFalse: ['instance']) translated, ', '. aStream nextPutAll: 'named' translated. aPair first allInstancesDo: [:inst | aStream space; nextPutAll: inst externalName]. aStream cr]. aStream cr. aList do: [:aPair | aStream cr. aStream nextPutAll: '--------------------------------------------------------------------------------------------'. aStream cr; nextPutAll: aPair first typicalInstanceName. aStream nextPutAll: '''s' translated. aStream nextPutAll: ' scripts:' translated. aPair first addDocumentationForScriptsTo: aStream]]. (StringHolder new contents: aString) openLabel: 'All scripts in this project' translated "self currentWorld presenter reportPlayersAndScripts"! ! !Presenter methodsFor: 'scripting' stamp: 'ar 3/17/2001 20:14'! adaptedToWorld: aWorld "If I refer to a world or a hand, return the corresponding items in the new world." ^aWorld presenter! ! !Presenter methodsFor: 'standardPlayer etc' stamp: 'yo 1/14/2005 19:37'! createStandardPlayer | aMorph | aMorph _ ImageMorph new image: (ScriptingSystem formAtKey: 'standardPlayer'). associatedMorph addMorphFront: aMorph. standardPlayer _ aMorph assuredPlayer renameTo: 'dot' translated. aMorph setBalloonText: '...'. self positionStandardPlayer. ^ standardPlayer! ! !Presenter methodsFor: 'standardPlayer etc' stamp: 'sw 1/20/2004 20:08'! positionStandardPlayer "Put the standard player slightly off-screen" standardPlayer ifNotNil: [standardPlayer costume position: (associatedMorph topLeft - (13@0))]! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:17'! allGoButtons "Answer a list of all script-controlling Go buttons within my scope" ^ associatedMorph allMorphs select: [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: [aMorph actionSelector == #goUp:with:]] "ActiveWorld presenter allGoButtons"! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:19'! allStepButtons "Answer a list of all the script-controlling Step buttons within my scope" ^ associatedMorph allMorphs select: [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: [aMorph actionSelector == #stepStillDown:with:]] "ActiveWorld presenter allStepButtons"! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:18'! allStopButtons "Answer a list of all script-controlling Stop buttons within my scope" ^ associatedMorph allMorphs select: [:aMorph | (aMorph isKindOf: ThreePhaseButtonMorph) and: [aMorph actionSelector == #stopUp:with:]] "ActiveWorld presenter allStopButtons"! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:08'! goButtonState: newState "Get all go buttons in my scope to show the correct state" self allGoButtons do: [:aButton | aButton state: newState]! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:43'! startRunningScripts "Start running scripts; get stop-step-go buttons to show the right thing" self stopButtonState: #off. self stepButtonState: #off. self goButtonState: #on. associatedMorph startRunningAll. "associatedMorph borderColor: Preferences borderColorWhenRunning." ThumbnailMorph recursionReset. "needs to be done once in a while (<- tk note from 1997)"! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:43'! startRunningScriptsFrom: ignored "Start running all scripts. Get all script-control buttons to show the right thing." self startRunningScripts! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:10'! stepButtonState: newState "Get all step buttons in my scope to show the correct state" self allStepButtons do: [:aButton | aButton state: newState]! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:06'! stepStillDown: dummy with: theButton "The step button is still down; get temporary button feedback right and step all and then get all button feedback right again" self stepButtonState: #pressed. self stopButtonState: #off. associatedMorph stepAll. associatedMorph world displayWorld. self stepButtonState: #off. self stopButtonState: #on ! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:06'! stepUp: evt with: aMorph "The step button came up; get things right" self stepButtonState: #off! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 14:08'! stopButtonState: newState "Get all stop buttons in my scope to show the correct state" self allStopButtons do: [:aButton | aButton state: newState]! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:42'! stopRunningScripts "Put all ticking scripts within my scope into paused mode. Get any scripting-control buttons to show the correct state" self stopButtonState: #on. self stepButtonState: #off. self goButtonState: #off. associatedMorph stopRunningAll. "associatedMorph borderColor: Preferences borderColorWhenStopped"! ! !Presenter methodsFor: 'stop-step-go buttons' stamp: 'sw 11/13/2001 18:42'! stopRunningScriptsFrom: ignored "Stop running scripts; get all script-control buttons to reflect this" self stopRunningScripts! ! !Presenter methodsFor: 'tile support' stamp: 'dgd 2/22/2003 19:08'! booleanTiles "Answer some boolean-valued tiles. This dates back to very early etoy work in 1997, and presently has no sent senders" | list rcvr op arg | list := #(#(0 #< 1) #(0 #<= 1) #(0 #= 1) #(0 #~= 1) #(0 #> 1) #(0 #>= 1)). list := list asOrderedCollection collect: [:entry | rcvr := entry first. op := (entry second) asSymbol. arg := entry last. self phraseForReceiver: rcvr op: op arg: arg resultType: #Boolean]. list add: (self phraseForReceiver: Color red op: #= arg: Color red resultType: #Boolean). ^list "copyWith: CompoundTileMorph new"! ! !Presenter methodsFor: 'tile support' stamp: 'gm 2/22/2003 14:53'! constantTile: anObject "Answer a constant tile that represents the object" (anObject isColor) ifTrue: [^ColorTileMorph new typeColor: (ScriptingSystem colorForType: #Color)]. ^anObject newTileMorphRepresentative typeColor: (ScriptingSystem colorForType: (self typeForConstant: anObject))! ! !Presenter methodsFor: 'tile support' stamp: 'dgd 2/21/2003 22:35'! phraseForReceiver: rcvr op: op arg: arg resultType: resultType "Answer a PhraseTileMorph affiliated with the given receiver, initialized to hold the given operator, argument, and result type" | m argTile rcvrTile | arg isNil ifTrue: [m := PhraseTileMorph new setOperator: op type: resultType rcvrType: (self typeForConstant: rcvr)] ifFalse: [m := PhraseTileMorph new setOperator: op type: resultType rcvrType: (self typeForConstant: rcvr) argType: (self typeForConstant: arg). argTile := self constantTile: arg. argTile position: m lastSubmorph position. m lastSubmorph addMorph: argTile]. rcvrTile := self constantTile: rcvr. " TilePadMorph makeReceiverColorOfResultType ifTrue: [rcvrTile color: m color]." rcvrTile position: m firstSubmorph position. m firstSubmorph addMorph: rcvrTile. m vResizing: #shrinkWrap. ^m! ! !Presenter methodsFor: 'tile support' stamp: 'sw 9/27/2001 17:43'! valueTiles "Answer some constant-valued tiles. This dates back to very early etoy work in 1997, and presently has no senders" | tiles | tiles _ OrderedCollection new. tiles add: (5 newTileMorphRepresentative typeColor: (ScriptingSystem colorForType: #Number)). tiles add: (ColorTileMorph new typeColor: (ScriptingSystem colorForType: #Color)). tiles add: (TileMorph new typeColor: (ScriptingSystem colorForType: #Number); setExpression: '(180 atRandom)' label: 'random'). tiles add: RandomNumberTile new. ^ tiles! ! !Presenter methodsFor: 'viewer' stamp: 'sw 2/19/2001 15:41'! cacheSpecs: aMorph "For SyntaxMorph's type checking, cache the list of all viewer command specifications." aMorph world ifNil: [^ true]. Preferences universalTiles ifFalse: [^ true]. Preferences eToyFriendly ifFalse: [^ true]. "not checking" (Project current projectParameterAt: #fullCheck ifAbsent: [false]) ifFalse: [^ true]. "not checking" SyntaxMorph initialize.! ! !Presenter methodsFor: 'viewer' stamp: 'sw 5/4/2001 04:27'! nascentPartsViewerFor: aViewee "Create a new, naked Viewer object for viewing aViewee. Give it a vocabulary if either the viewee insists on one or if the project insists on one." | aViewer aVocab | aViewer _ StandardViewer new. (aVocab _ aViewee vocabularyDemanded) ifNotNil: [aViewer useVocabulary: aVocab] ifNil: [(aVocab _ associatedMorph currentVocabularyFor: aViewee) ifNotNil: [aViewer useVocabulary: aVocab]]. "If the viewee does not *demand* a special kind of Viewer, and if the project has not specified a preferred vocabulary, then the system defaults will kick in later" ^ aViewer! ! !Presenter methodsFor: 'viewer' stamp: 'md 12/12/2003 16:22'! updateViewer: aViewer forceToShow: aCategorySymbol "Update the given viewer to make sure it is in step with various possible changes in the outside world, and when reshowing it be sure it shows the given category" | aPlayer aPosition newViewer oldOwner wasSticky barHeight itsVocabulary aCategory categoryInfo | aCategory _ aCategorySymbol ifNotNil: [aViewer currentVocabulary translatedWordingFor: aCategorySymbol]. categoryInfo _ aViewer categoryMorphs asOrderedCollection collect: [:aMorph | aMorph categoryRestorationInfo]. itsVocabulary _ aViewer currentVocabulary. aCategory ifNotNil: [(categoryInfo includes: aCategorySymbol) ifFalse: [categoryInfo addFirst: aCategorySymbol]]. aPlayer _ aViewer scriptedPlayer. aPosition _ aViewer position. wasSticky _ aViewer isSticky. newViewer _ aViewer species new visible: false. barHeight _ aViewer submorphs first listDirection == #topToBottom ifTrue: [aViewer submorphs first submorphs first height] ifFalse: [0]. Preferences viewersInFlaps ifTrue: [newViewer setProperty: #noInteriorThumbnail toValue: true]. newViewer rawVocabulary: itsVocabulary. newViewer limitClass: aViewer limitClass. newViewer initializeFor: aPlayer barHeight: barHeight includeDismissButton: aViewer hasDismissButton showCategories: categoryInfo. wasSticky ifTrue: [newViewer beSticky]. oldOwner _ aViewer owner. oldOwner ifNotNil: [oldOwner replaceSubmorph: aViewer by: newViewer]. "It has happened that old readouts are still on steplist. We may see again!!" newViewer position: aPosition. newViewer enforceTileColorPolicy. newViewer visible: true. newViewer world ifNotNilDo: [:aWorld | aWorld startSteppingSubmorphsOf: newViewer]. newViewer layoutChanged! ! !Presenter methodsFor: 'viewer' stamp: 'nk 9/21/2003 12:53'! viewMorph: aMorph | aPlayer openViewers aViewer aPalette aRect aPoint nominalHeight aFlapTab topItem flapLoc | Sensor leftShiftDown ifFalse: [((aPalette := aMorph standardPalette) notNil and: [aPalette isInWorld]) ifTrue: [^aPalette viewMorph: aMorph]]. aPlayer := (topItem := aMorph topRendererOrSelf) assuredPlayer. openViewers _ aPlayer allOpenViewers. aViewer := openViewers isEmpty ifFalse: [ openViewers first ] ifTrue: [ self nascentPartsViewer ]. self cacheSpecs: topItem. "redo the spec cache once in a while" "19 sept 2000 - allow flaps in any paste up" flapLoc := associatedMorph. "world" Preferences viewersInFlaps ifTrue: [ aViewer owner ifNotNilDo: [ :f | ^f flapTab showFlap; yourself ]. aViewer setProperty: #noInteriorThumbnail toValue: true. aViewer initializeFor: aPlayer barHeight: 0. aViewer enforceTileColorPolicy. aViewer fullBounds. "force layout" "associatedMorph addMorph: aViewer." "why???" flapLoc hideViewerFlapsOtherThanFor: aPlayer. aFlapTab := flapLoc viewerFlapTabFor: topItem. aFlapTab referent submorphs do: [:m | (m isKindOf: Viewer) ifTrue: [m delete]]. aViewer visible: true. aFlapTab applyThickness: aViewer width + 25. aFlapTab spanWorld. aFlapTab showFlap. aViewer position: aFlapTab referent position. aFlapTab referent addMorph: aViewer beSticky. "moved" flapLoc startSteppingSubmorphsOf: aFlapTab. flapLoc startSteppingSubmorphsOf: aViewer. ^aFlapTab]. aViewer initializeFor: aPlayer barHeight: 6. aViewer enforceTileColorPolicy. aViewer fullBounds. "force layout" Preferences automaticViewerPlacement ifTrue: [aPoint := aMorph bounds right @ (aMorph center y - ((nominalHeight := aViewer initialHeightToAllow) // 2)). aRect := (aPoint extent: aViewer width @ nominalHeight) translatedToBeWithin: flapLoc bounds. aViewer position: aRect topLeft. aViewer visible: true. associatedMorph addMorph: aViewer. flapLoc startSteppingSubmorphsOf: aViewer. "it's already in the world, somewhat coincidentally" ^aViewer]. aMorph primaryHand attachMorph: (aViewer visible: true). ^aViewer! ! !Presenter methodsFor: 'viewer' stamp: 'sw 6/20/2001 12:37'! viewObject: anObject "Open up and return a viewer on the given object. If the object is a Morph, open a viewer on its associated Player" anObject isMorph ifTrue: [self viewMorph: anObject] "historic morph/player implementation" ifFalse: [self viewObjectDirectly: anObject]! ! !Presenter methodsFor: 'viewer' stamp: 'sw 6/20/2001 13:12'! viewObjectDirectly: anObject "Open up and return a viewer on the given object" | aViewer aRect aPoint nominalHeight aFlapTab flapLoc | associatedMorph addMorph: (aViewer _ self nascentPartsViewerFor: anObject). flapLoc _ associatedMorph "world". Preferences viewersInFlaps ifTrue: [aViewer setProperty: #noInteriorThumbnail toValue: true. aViewer initializeFor: anObject barHeight: 0. aViewer enforceTileColorPolicy. flapLoc hideViewerFlapsOtherThanFor: anObject. aFlapTab _ flapLoc viewerFlapTabFor: anObject. aFlapTab referent submorphs do: [:m | (m isKindOf: Viewer) ifTrue: [m delete]]. aFlapTab referent addMorph: aViewer beSticky. aViewer visible: true. aFlapTab applyThickness: aViewer width + 25. aFlapTab spanWorld. aFlapTab showFlap. aViewer position: aFlapTab referent position. flapLoc startSteppingSubmorphsOf: aFlapTab. flapLoc startSteppingSubmorphsOf: aViewer. ^ aFlapTab]. "Caution: the branch below is historical and has not been used for a long time, though if you set the #viewersInFlaps preference to false you'd hit it. Not at all recently maintained." aViewer initializeFor: anObject barHeight: 6. aViewer enforceTileColorPolicy. Preferences automaticViewerPlacement ifTrue: [aPoint _ anObject bounds right @ (anObject center y - ((nominalHeight _ aViewer initialHeightToAllow) // 2)). aRect _ (aPoint extent: (aViewer width @ nominalHeight)) translatedToBeWithin: flapLoc bounds. aViewer position: aRect topLeft. aViewer visible: true. flapLoc startSteppingSubmorphsOf: aViewer. "it's already in the world, somewhat coincidentally" ^ aViewer]. anObject primaryHand attachMorph: (aViewer visible: true). ^aViewer! ! !Presenter methodsFor: 'intialize' stamp: 'sw 12/13/2004 16:58'! allExtantPlayers "The initial intent here was to produce a list of Player objects associated with any Morph in the tree beneath the receiver's associatedMorph. whether it is the submorph tree or perhaps off on unseen bookPages. We have for the moment moved away from that initial intent, and in the current version we only deliver up players associated with the submorph tree only. <-- this note dates from 4/21/99 Call #flushPlayerListCache; to force recomputation." | fullList objectsReferredToByTiles | playerList ifNotNil: [^ playerList]. fullList _ associatedMorph allMorphs select: [:m | m player ~~ nil] thenCollect: [:m | m player]. fullList copy do: [:aPlayer | aPlayer class scripts do: [:aScript | aScript isTextuallyCoded ifFalse: [aScript currentScriptEditor ifNotNilDo: [:ed | objectsReferredToByTiles _ ed allMorphs select: [:aMorph | (aMorph isKindOf: TileMorph) and: [aMorph type == #objRef]] thenCollect: [:aMorph | aMorph actualObject]. fullList addAll: objectsReferredToByTiles]]]]. ^ playerList _ (fullList asSet asSortedCollection: [:a :b | a externalName < b externalName]) asArray! ! !Presenter commentStamp: '<historical>' prior: 0! Optionally associated with a PasteUpMorph, provides a local scope for the running of scripts. Once more valuable, may be again, but at present occupies primarily a historical niche. Maintains a playerList cache. Holds, optionally three 'standard items' -- standardPlayer standardPlayfield standardPalette -- originally providing idiomatic support of ongoing squeak-team internal work, but now extended to more general applicability. ! !PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:52'! changeStatusOfFailedCallsFlag ^changeStatusOfFailedCallsFlag! ! !PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/11/2004 04:12'! logStream ^logStream! ! !PrimCallControllerAbstract methodsFor: 'accessing' stamp: 'sr 6/2/2004 05:27'! treatedMethods ^treatedMethods! ! !PrimCallControllerAbstract methodsFor: 'initialize-release' stamp: 'sr 6/11/2004 05:39'! initialize treatedMethods _ Dictionary new. " logStream _ Transcript." changeStatusOfFailedCallsFlag _ false! ! !PrimCallControllerAbstract methodsFor: 'logging' stamp: 'sr 6/11/2004 05:12'! log: aString self logStream ifNotNil: [self logStream cr; show: '[' , self className , '] ' , aString]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:39'! changeStatusOfFailedCalls "En/dis-able not only dis/en-abled calls, but also failed ones. Using this feature can hide serious problems." changeStatusOfFailedCallsFlag := true! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:15'! disableCallIn: aMethodRef "Disables enabled external prim call." (self existsEnabledCallIn: aMethodRef) ifFalse: [self changeStatusOfFailedCallsFlag ifTrue: [(self existsFailedCallIn: aMethodRef) ifFalse: [^ self error: 'no enabled or failed prim call found']] ifFalse: [^ self error: 'no enabled prim call found']]. self privateDisableCallIn: aMethodRef. self treatedMethods at: aMethodRef put: #disabled. self logStream ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' disabled.']! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:30'! disableCallInCompiledMethod: aCompiledMethod "Disables external prim call." self changeCallCompiledMethod: aCompiledMethod enable: false! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! disableCallInMethod: selector class: classOrSymbol "Disables external prim call." self changeCallMethod: selector class: classOrSymbol enable: false! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:35'! disableCallsIntoModule: aModule "Disables enabled external prim calls in aModule." | methods | methods := self methodsWithEnabledCallIntoModule: aModule. self changeStatusOfFailedCallsFlag ifTrue: [methods addAll: (self methodsWithFailedCallIntoModule: aModule)]. methods isEmpty ifTrue: [^ self error: 'no enabled ' , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) , 'prim calls for module ' , aModule , ' found']. methods do: [:mRef | self disableCallIn: mRef]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'! disableCallsIntoModule: aModule forClasses: classes "Disables enabled external prim calls in aModule for classes." | methods | methods := self methodsWithEnabledCallIntoModule: aModule forClasses: classes. self changeStatusOfFailedCallsFlag ifTrue: [methods addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)]. methods isEmpty ifTrue: [^ self error: 'no enabled ' , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) , 'prim calls for module ' , aModule , ' in given classes found']. methods do: [:mRef | self disableCallIn: mRef]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:44'! disableEnabled "Disables these external prim calls, which are formerly enabled by self." self treatedMethods keysAndValuesDo: [:mRef :status | status == #enabled ifTrue: [self disableCallIn: mRef]]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/14/2004 02:05'! enableCallIn: aMethodRef "Enables disabled external prim call." (self existsDisabledCallIn: aMethodRef) ifTrue: [self privateEnableCallIn: aMethodRef] ifFalse: [self changeStatusOfFailedCallsFlag ifTrue: [(self existsFailedCallIn: aMethodRef) ifTrue: [self privateEnableViaLiteralIn: aMethodRef] ifFalse: [^ self error: 'no disabled or failed prim call found']] ifFalse: [^ self error: 'no disabled prim call found']]. self treatedMethods at: aMethodRef put: #enabled. self logStream ifNotNil: [self log: 'Call ' , (self extractCallModuleNames: aMethodRef) printString , ' in ' , aMethodRef actualClass name , '>>' , aMethodRef methodSymbol , ' enabled.']! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! enableCallInCompiledMethod: aCompiledMethod "Enables disabled external prim call." self changeCallCompiledMethod: aCompiledMethod enable: true! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:31'! enableCallInMethod: selector class: classOrSymbol "Enables disabled external prim call." self changeCallMethod: selector class: classOrSymbol enable: true! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 01:36'! enableCallsIntoModule: aModule "Enables disabled external prim calls in aModule." | methods | methods := self methodsWithDisabledCallIntoModule: aModule. self changeStatusOfFailedCallsFlag ifTrue: [methods addAll: (self methodsWithFailedCallIntoModule: aModule)]. methods isEmpty ifTrue: [^ self error: 'no disabled ' , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) , 'prim calls for module ' , aModule , ' found']. methods do: [:mRef | self enableCallIn: mRef]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 02:01'! enableCallsIntoModule: aModule forClasses: classes "Enables disabled external prim calls in aModule for classes." | methods | methods := self methodsWithDisabledCallIntoModule: aModule forClasses: classes. self changeStatusOfFailedCallsFlag ifTrue: [methods addAll: (self methodsWithFailedCallIntoModule: aModule forClasses: classes)]. methods isEmpty ifTrue: [^ self error: 'no disabled ' , (self changeStatusOfFailedCallsFlag ifTrue: ['or failed '] ifFalse: ['']) , 'prim calls for module ' , aModule , ' in given classes found']. methods do: [:mRef | self enableCallIn: mRef]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:42'! enableDisabled "Enables these external prim calls, which are formerly disabled by self." self treatedMethods keysAndValuesDo: [:mRef :status | status == #disabled ifTrue: [self enableCallIn: mRef]]! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/15/2004 17:41'! preserveStatusOfFailedCalls "Do not en/dis-able failed calls (default)." changeStatusOfFailedCallsFlag := false! ! !PrimCallControllerAbstract methodsFor: 'ui controlling' stamp: 'sr 6/11/2004 06:45'! switchStored "Disables enabled and enables disabled (see corresponding method comments). " self treatedMethods keysAndValuesDo: [:mRef :status | status == #enabled ifTrue: [self disableCallIn: mRef] ifFalse: [self enableCallIn: mRef]]! ! !PrimCallControllerAbstract methodsFor: 'ui logging' stamp: 'sr 6/11/2004 04:17'! logStream: aStreamOrNil "If aStreamOrNil is notNil, there will be shown dis/en-abling prim call info; nil means no logging." logStream := aStreamOrNil! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/10/2004 21:15'! extractCallModuleNames: aMethodRef "Returns prim call and module name as call->module Association." self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:27'! methodsWithCall "Returns all methods containing external prim calls." self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:15'! methodsWithCall: primName ^ self methodsWithCall: primName enabled: nil! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:12'! methodsWithCall: primName intoModule: moduleNameOrNil ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: nil! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:20'! methodsWithCallIntoModule: moduleNameOrNil ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: nil! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'! methodsWithCallIntoModule: moduleNameOrNil forClass: class ^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: {class}! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 19:30'! methodsWithCallIntoModule: moduleNameOrNil forClasses: classes ^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: nil! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:36'! methodsWithCompiledCall "Returns all methods containing compiled in external prim calls. If the by compilation subclass has disabled some, this method does *not* return all methods containing prim calls (use >>methodsWithCall in this case). " ^ (SystemNavigation new allMethodsSelect: [:method | method primitive = 117]) reject: [:method | method actualClass == ProtoObject]! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'! methodsWithDisabledCall "Returns all methods containing disabled external prim calls." self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'! methodsWithDisabledCall: primName ^ self methodsWithCall: primName enabled: false! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'! methodsWithDisabledCall: primName intoModule: moduleNameOrNil ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: false! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:25'! methodsWithDisabledCallIntoModule: moduleNameOrNil ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: false! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:24'! methodsWithDisabledCallIntoModule: moduleNameOrNil forClass: class ^ self methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: {class}! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:20'! methodsWithDisabledCallIntoModule: moduleNameOrNil forClasses: classes ^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: false! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/14/2004 21:28'! methodsWithEnabledCall "Returns all methods containing enabled external prim calls." ^ self methodsWithCompiledCall select: [:mRef | (mRef compiledMethod literals first at: 4) >= 0]! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:15'! methodsWithEnabledCall: primName ^ self methodsWithCall: primName enabled: true! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:16'! methodsWithEnabledCall: primName intoModule: moduleNameOrNil ^ self methodsWithCall: primName intoModule: moduleNameOrNil enabled: true! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:11'! methodsWithEnabledCallIntoModule: moduleNameOrNil ^ self methodsWithCallIntoModule: moduleNameOrNil enabled: true! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 05:46'! methodsWithEnabledCallIntoModule: moduleNameOrNil forClass: class ^ self methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: {class}! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/11/2004 06:07'! methodsWithEnabledCallIntoModule: moduleNameOrNil forClasses: classes ^ self methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: true! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 20:47'! methodsWithFailedCall "Returns all methods containing failed external prim calls." ^ self methodsWithCompiledCall select: self blockSelectFailedCall! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:40'! methodsWithFailedCallForClass: class ^ class selectors collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel] thenSelect: [:mRef | self existsFailedCallIn: mRef]! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 01:44'! methodsWithFailedCallForClasses: classes | result | result := OrderedCollection new. classes do: [:class | result addAll: (self methodsWithFailedCallForClass: class)]. ^ result! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'! methodsWithFailedCallIntoModule: moduleNameOrNil ^ self methodsWithFailedCall select: (self blockSelectModuleName: moduleNameOrNil)! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 02:19'! methodsWithFailedCallIntoModule: moduleNameOrNil forClass: class ^ self methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: {class}! ! !PrimCallControllerAbstract methodsFor: 'ui querying' stamp: 'sr 6/15/2004 19:58'! methodsWithFailedCallIntoModule: moduleNameOrNil forClasses: classes ^ (self methodsWithFailedCallForClasses: classes) select: (self blockSelectModuleName: moduleNameOrNil)! ! !PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 07:31'! existsCallIn: aMethodRef self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/9/2004 02:12'! existsDisabledCallIn: aMethodRef self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/11/2004 06:34'! existsEnabledCallIn: aMethodRef ^ (self existsCompiledCallIn: aMethodRef) and: [(aMethodRef compiledMethod literals first at: 4) >= 0]! ! !PrimCallControllerAbstract methodsFor: 'ui testing' stamp: 'sr 6/15/2004 20:46'! existsFailedCallIn: aMethodRef ^ (self existsCompiledCallIn: aMethodRef) and: [self blockSelectFailedCall value: aMethodRef]! ! !PrimCallControllerAbstract methodsFor: 'private' stamp: 'sr 6/10/2004 21:32'! extractCallModuleNamesFromLiterals: aMethodRef | firstLiteral | firstLiteral := aMethodRef compiledMethod literals first. ^ (firstLiteral at: 2) -> (firstLiteral at: 1)! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:49'! blockSelectCallName: callName ^ [:mRef | (self extractCallModuleNames: mRef) key = callName]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:45'! blockSelectFailedCall "Precondition: mRef references compiledCall." ^ [:mRef | (mRef compiledMethod literals first at: 4) = -1]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:50'! blockSelectModuleName: moduleNameOrNil ^ [:mRef | (self extractCallModuleNames: mRef) value = moduleNameOrNil]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 17:30'! changeCallCompiledMethod: aCompiledMethod enable: enableFlag "Enables disabled or disables enabled external prim call by recompiling method with prim call taken from comment." | who methodRef | who := aCompiledMethod who. methodRef := MethodReference new setStandardClass: (who at: 1) methodSymbol: (who at: 2). enableFlag ifTrue: [self enableCallIn: methodRef] ifFalse: [self disableCallIn: methodRef]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 17:31'! changeCallMethod: selector class: classOrSymbol enable: enableFlag "Enables disabled or disables enabled external prim call by recompiling method with prim call taken from comment." | methodRef | methodRef := MethodReference new setStandardClass: (classOrSymbol isSymbol ifTrue: [Smalltalk at: classOrSymbol] ifFalse: [classOrSymbol]) methodSymbol: selector. enableFlag ifTrue: [self enableCallIn: methodRef] ifFalse: [self disableCallIn: methodRef]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/11/2004 06:31'! existsCompiledCallIn: aMethodRef "This just means that there is a compiled in external prim call: from the by compiler subclass point of view disabled prim calls not visible by this method are also prim calls." ^ aMethodRef compiledMethod primitive = 117! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:59'! methodsWithCall: callName enabled: enabledFlag ^ (self methodsWithCallEnabled: enabledFlag) select: (self blockSelectCallName: callName)! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 20:24'! methodsWithCall: callName intoModule: moduleNameOrNil enabled: enabledFlag ^ ((self methodsWithCallEnabled: enabledFlag) select: (self blockSelectCallName: callName)) select: (self blockSelectModuleName: moduleNameOrNil)! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:17'! methodsWithCallEnabled: enabledFlag ^ enabledFlag ifNil: [self methodsWithCall] ifNotNil: [enabledFlag ifTrue: [self methodsWithEnabledCall] ifFalse: [self methodsWithDisabledCall]]! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 19:19'! methodsWithCallForClass: class enabled: enabledFlag ^ class selectors collect: [:sel | MethodReference new setStandardClass: class methodSymbol: sel] thenSelect: (enabledFlag ifNil: [[:mRef | self existsCallIn: mRef]] ifNotNil: [enabledFlag ifTrue: [[:mRef | self existsEnabledCallIn: mRef]] ifFalse: [[:mRef | self existsDisabledCallIn: mRef]]])! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/13/2004 20:00'! methodsWithCallForClasses: classes enabled: enabledFlag | result | result := OrderedCollection new. classes do: [:class | result addAll: (self methodsWithCallForClass: class enabled: enabledFlag)]. ^ result! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:55'! methodsWithCallIntoModule: moduleNameOrNil enabled: enabledFlag ^ (self methodsWithCallEnabled: enabledFlag) select: (self blockSelectModuleName: moduleNameOrNil)! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/15/2004 19:57'! methodsWithCallIntoModule: moduleNameOrNil forClasses: classes enabled: enabledFlag ^ (self methodsWithCallForClasses: classes enabled: enabledFlag) select: (self blockSelectModuleName: moduleNameOrNil)! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:34'! privateDisableCallIn: aMethodRefWithExternalCall "Disables enabled or failed external prim call." self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 01:33'! privateEnableCallIn: aMethodRefWithExternalCall "Enables disabled external prim call." self subclassResponsibility! ! !PrimCallControllerAbstract methodsFor: 'private user interface' stamp: 'sr 6/14/2004 02:09'! privateEnableViaLiteralIn: aMethodRef "Enables external prim call by filling function ref literal with zero for 'non called'." aMethodRef compiledMethod literals first at: 4 put: 0. Object flushCache! ! !PrimCallControllerAbstract commentStamp: 'sr 6/16/2004 09:42' prior: 0! A PrimCallController (PCC) serves for switching external prim calls (primitiveExternalCall) on and off: this is an abstract class, instantiate one of the subclasses PCCByLiterals and PCCByCompilation. External prim calls are used to access internal and external modules (plugins) as shown by SmalltalkImage current listLoadedModules. SmalltalkImage current listBuiltinModules. Note: not loaded external modules (since they have not been called so far) are not shown by these methods. Highlight: dis/en-abling prims by a PCC works for both internal and external modules!! To help you choosing the right subclass, some properties are listed in the following table: Functionality/Property | PCCByLiterals PCCByCompilation ------------------------------------------------------------------------------------------------------ testing plugins | suited not suited permanent disabling of external prim calls | no yes ------------------------------------------------------------------------------------------------------ method changes visible in changeset | no yes enabling survives snapshot/compilation | yes yes disabling survives snapshot/compilation | no yes speed disabling | fast medium speed enabling | fast slow CompiledMethod pointer valid after en/dis-abling | yes no Important: Be careful with mixing the use of different PCCs!! PCCByLiterals does not see prims disabled by PCCByCompilation and vice versa. For playing around you should start with PCCByLiterals; use PCCByCompilation only, if you know what you are doing!! In protocols 'ui controlling', 'ui logging' and 'ui querying' (please look into this class) are the most important user interface methods. Thereafter the methods in 'ui testing' could be of interest. Useful expressions: Controlling: "Factorial example" | pcc tDisabled tEnabled tEnabled2 | pcc _ PCCByLiterals new logStream: Transcript. "logStream set here for more info" pcc disableCallsIntoModule: 'LargeIntegers'. tDisabled _ [1000 factorial] timeToRun. pcc enableDisabled. tEnabled _ [1000 factorial] timeToRun. tEnabled2 _ [1000 factorial] timeToRun. {tDisabled. tEnabled. tEnabled2} Note: You shouldn't switch off module 'LargeIntegers' for a longer time, since this slows down your system. Querying: PCCByLiterals new methodsWithCall. "all calls" PCCByLiterals new methodsWithCall: 'prim1'. "call in all modules or without module" PCCByLiterals new methodsWithCallIntoModule: nil. "all calls without module" PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers'. "all calls into module 'LargeIntegers'" PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers' forClass: Integer. "all calls into module 'LargeIntegers' in class Integer" PCCByLiterals new methodsWithCallIntoModule: 'LargeIntegers' forClasses: Integer withAllSubclasses. "all calls into module 'LargeIntegers' in class Integer withAllSubclasses" | pcc | (pcc _ PCCByLiterals new) methodsWithCall collect: [:mRef | {mRef. pcc extractCallModuleNames: mRef}]. Structure: treatedMethods Dictionary of MethodReferences->#disabled/#enabled -- contains changed methods and how they are changed last logStream WriteStream -- shows info about changed methods ifNotNil changeStatusOfFailedCalls Boolean -- if status of failed calls should be changed, default is false! ]style[(165 13 5 16 339 26 792 10 84 8 120 31 82 4 118 19 17 18 2 452 29 37 18 15 56 1 18 26 35 2 18 26 79 26 122 26 170 79 1 320)f2FAccuny#12,f2LPCCByLiterals Comment;,f2FAccuny#12,f2LPCCByCompilation Comment;,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#12b,f2FAccuny#12,f2FAccuny#12i,f2FAccuny#12,f2FAccuny#15,f2FAccuny#12,f2,f2u,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2,f2FAccuny#12,f2! !PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/14/2004 22:56'! avoidSlowTest ^ doNotMakeSlowTestsFlag and: [pcc class = PCCByCompilation]! ! !PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:56'! disabledCallRefs ^ self disabledCallSelectors collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! ! !PrimCallControllerAbstractTest methodsFor: 'helper' stamp: 'sr 6/7/2004 08:57'! enabledCallRefs ^ self enabledCallSelectors collect: [:sel | MethodReference new setStandardClass: self class methodSymbol: sel]! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'! compiledMethodsToExampleModule ^ self methodSelectorsToExampleModule collect: [:sel | self class >> sel]! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 00:11'! failedCallRef ^ MethodReference new setStandardClass: self class methodSymbol: self failedCallSelector! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:46'! methodRefsToExampleModule ^ self methodSelectorsToExampleModule collect: [:sym | MethodReference new setStandardClass: self class methodSymbol: sym]! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 13:58'! noExternalCallRef ^ MethodReference new setStandardClass: self class methodSymbol: self noExternalCallSelector! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:47'! numOfCallsExampleModule ^ self methodSelectorsToExampleModule size! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/14/2004 23:34'! singularCallRef ^ MethodReference new setStandardClass: self class methodSymbol: self singularCallSelector! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'! wrongCallRef ^ MethodReference new setStandardClass: self class methodSymbol: #nonExistingCall! ! !PrimCallControllerAbstractTest methodsFor: 'constants' stamp: 'sr 6/7/2004 08:49'! wrongClassRef ^ MethodReference new setStandardClass: Integer methodSymbol: self methodSelectorsToExampleModule first! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 04:37'! setUp super setUp. pcc := self classToBeTested new. "set failed call" (self class >> self failedCallSelector) literals first at: 4 put: -1. "set it to false for some very slow tests..." doNotMakeSlowTestsFlag := true! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:54'! testChangeFailedCallFailing pcc preserveStatusOfFailedCalls. self should: [pcc enableCallIn: self failedCallRef] raise: TestResult error. self should: [pcc disableCallIn: self failedCallRef] raise: TestResult error! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:41'! testChangeFailedCallSucceedingDisable pcc changeStatusOfFailedCalls. pcc disableCallIn: self failedCallRef. self assert: (pcc existsDisabledCallIn: self failedCallRef). "necessary for PCCByCompilation (to make it visible for initialization again)" pcc enableCallIn: self failedCallRef! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:34'! testChangeFailedCallSucceedingEnable pcc changeStatusOfFailedCalls. pcc enableCallIn: self failedCallRef. self assert: (pcc existsEnabledCallIn: self failedCallRef)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'! testDisableCallsIntoModule "wrong module" self should: [pcc disableCallsIntoModule: 'totallyRandom4711'] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "disabling" pcc disableCallsIntoModule: self exampleModuleName. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "not enabled!!" self should: [pcc disableCallsIntoModule: self exampleModuleName] raise: TestResult error. "enabling" self methodRefsToExampleModule do: [:ref | pcc enableCallIn: ref]. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not enabled!!" self should: [pcc disableCallsIntoModule: self failModuleName] raise: TestResult error. pcc changeStatusOfFailedCalls. pcc disableCallsIntoModule: self failModuleName. self assert: (pcc existsDisabledCallIn: self failedCallRef). "postcondition" pcc enableCallIn: self failedCallRef ! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:24'! testDisableCallsIntoModuleForClasses "wrong module" self should: [pcc disableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "disabling" pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "not enabled!!" self should: [pcc disableCallsIntoModule: self exampleModuleName forClasses: {self class}] raise: TestResult error. "enabling" self methodRefsToExampleModule do: [:ref | pcc enableCallIn: ref]. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not enabled!!" self should: [pcc disableCallsIntoModule: self failModuleName forClasses: {self class}] raise: TestResult error. pcc changeStatusOfFailedCalls. pcc disableCallsIntoModule: self failModuleName forClasses: {self class}. self assert: (pcc existsDisabledCallIn: self failedCallRef). "postcondition" pcc enableCallIn: self failedCallRef ! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:43'! testEnableCallsIntoModule self avoidSlowTest ifTrue: [^ self]. "wrong module" self should: [pcc enableCallsIntoModule: 'totallyRandom4711'] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [pcc enableCallsIntoModule: self exampleModuleName] raise: TestResult error. "disabling" self methodRefsToExampleModule do: [:ref | pcc disableCallIn: ref]. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "enabling" "now this should work" pcc enableCallsIntoModule: self exampleModuleName. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [pcc enableCallsIntoModule: self failModuleName] raise: TestResult error. pcc changeStatusOfFailedCalls. pcc enableCallsIntoModule: self failModuleName. self assert: (pcc existsEnabledCallIn: self failedCallRef) ! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:43'! testEnableCallsIntoModuleForClasses "wrong module" self should: [pcc enableCallsIntoModule: 'totallyRandom4711' forClasses: {self class}] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}] raise: TestResult error. "disabling" self methodRefsToExampleModule do: [:ref | pcc disableCallIn: ref]. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "enabling" "now this should work" pcc enableCallsIntoModule: self exampleModuleName forClasses: {self class}. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [pcc enableCallsIntoModule: self failModuleName forClasses: {self class}] raise: TestResult error. pcc changeStatusOfFailedCalls. pcc enableCallsIntoModule: self failModuleName forClasses: {self class}. self assert: (pcc existsEnabledCallIn: self failedCallRef) ! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:45'! testEnableDisableCallIn | refs | refs := self methodRefsToExampleModule. "wrong call" self should: [pcc disableCallIn: self wrongCallRef] raise: TestResult error. "wrong class" self should: [pcc disableCallIn: self wrongClassRef] raise: TestResult error. "wrong call" self should: [pcc enableCallIn: self wrongCallRef] raise: TestResult error. "wrong class" self should: [pcc enableCallIn: self wrongClassRef] raise: TestResult error. "no external call" self should: [pcc enableCallIn: self noExternalCallRef] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [refs do: [:ref1 | pcc enableCallIn: ref1]] raise: TestResult error. "disabling" refs do: [:ref2 | pcc disableCallIn: ref2]. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "not enabled!!" self should: [refs do: [:ref3 | pcc disableCallIn: ref3]] raise: TestResult error. "enabling" "now this should work" refs do: [:ref4 | pcc enableCallIn: ref4]. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "try caches" pcc disableEnabled. "all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. pcc enableDisabled. "all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 00:07'! testEnableDisableCallInCompiledMethod "Note: >>compiledMethodsToExampleModule has to be called frequently, since the CMs are changing with a successful compile!!" "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [self compiledMethodsToExampleModule do: [:cm1 | pcc enableCallInCompiledMethod: cm1]] raise: TestResult error. "disabling" self compiledMethodsToExampleModule do: [:cm2 | pcc disableCallInCompiledMethod: cm2]. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "not enabled!!" self should: [self compiledMethodsToExampleModule do: [:cm3 | pcc disableCallInCompiledMethod: cm3]] raise: TestResult error. "enabling" "now this should work" self compiledMethodsToExampleModule do: [:cm4 | pcc enableCallInCompiledMethod: cm4]. self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "try caches" pcc disableEnabled. "all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. pcc enableDisabled. "all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:57'! testEnableDisableCallInMethodClass | sels | sels := self methodSelectorsToExampleModule. "wrong call" self should: [pcc disableCallInMethod: #nonExistingCall class: self class] raise: TestResult error. "wrong class" self should: [pcc disableCallInMethod: sels first class: Integer] raise: TestResult error. "wrong call" self should: [pcc enableCallInMethod: #nonExistingCall class: self class] raise: TestResult error. "wrong class" self should: [pcc enableCallInMethod: sels first class: Integer] raise: TestResult error. self should: [pcc enableCallInMethod: self noExternalCallSelector class: self class] raise: TestResult error. "precondition: all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "not disabled!!" self should: [sels do: [:sel1 | pcc enableCallInMethod: sel1 class: self class]] raise: TestResult error. "disabling" sels do: [:sel2 | pcc disableCallInMethod: sel2 class: self class]. "now all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. "not enabled!!" self should: [sels do: [:sel3 | pcc disableCallInMethod: sel3 class: self class]] raise: TestResult error. "enabling" "now this should work" sels do: [:sel4 | pcc enableCallInMethod: sel4 class: self class]. "all enabled now" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. "try caches" pcc disableEnabled. "all disabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. pcc enableDisabled. "all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:46'! testExistsCallIn self deny: (pcc existsCallIn: self noExternalCallRef). self enabledCallRefs , self disabledCallRefs , {self failedCallRef} do: [:callRef | self assert: (pcc existsCallIn: callRef)]! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:47'! testExistsDisabledCallIn self deny: (pcc existsDisabledCallIn: self noExternalCallRef). self deny: (pcc existsDisabledCallIn: self failedCallRef). self enabledCallRefs do: [:callRef | self deny: (pcc existsDisabledCallIn: callRef)]. self disabledCallRefs do: [:disabledRef | self assert: (pcc existsDisabledCallIn: disabledRef)]! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:48'! testExistsEnabledCallIn self deny: (pcc existsEnabledCallIn: self noExternalCallRef). self deny: (pcc existsEnabledCallIn: self failedCallRef). self enabledCallRefs do: [:callRef | self assert: (pcc existsEnabledCallIn: callRef)]. self disabledCallRefs do: [:disabledRef | self deny: (pcc existsEnabledCallIn: disabledRef)]! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:49'! testExistsFailedCallIn self deny: (pcc existsFailedCallIn: self noExternalCallRef). self enabledCallRefs , self disabledCallRefs do: [:callRef | self deny: (pcc existsFailedCallIn: callRef)]. self assert: (pcc existsFailedCallIn: self failedCallRef)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:25'! testMethodsWithCallAndMethodsWithDisabledCall | methodRefs disabledMethodRefs enabledMethodRefs failedMethodRefs | self avoidSlowTest ifTrue: [^ self]. disabledMethodRefs := pcc methodsWithDisabledCall. self assert: disabledMethodRefs size > 0. enabledMethodRefs := pcc methodsWithEnabledCall. self assert: enabledMethodRefs size > 0. failedMethodRefs := pcc methodsWithFailedCall. self assert: failedMethodRefs size > 0. methodRefs := pcc methodsWithCall. self assert: methodRefs size = (disabledMethodRefs size + enabledMethodRefs size + failedMethodRefs size)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:54'! testMethodsWithCallIntoModule | methodRefs | self avoidSlowTest ifTrue: [^ self]. "precondition: all enabled" pcc disableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName. self assert: methodRefs size = self numOfCallsExampleModule. "postcondition" pcc enableCallIn: self methodRefsToExampleModule first! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:32'! testMethodsWithCallIntoModuleForClass "precondition: all enabled" | methodRefs | pcc disableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClass: self class. self assert: methodRefs size = self numOfCallsExampleModule. "postcondition" pcc enableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithCallIntoModule: nil forClass: self class. self assert: (methodRefs size = 2 and: [| methodCoreStrings | methodCoreStrings := methodRefs collect: [:mRef | mRef methodSymbol allButFirst asString]. (methodCoreStrings includes: 'ExternalCallWithoutModule') and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:31'! testMethodsWithCallIntoModuleForClasses "precondition: all enabled" | methodRefs | pcc disableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithCallIntoModule: self exampleModuleName forClasses: {self class}. self assert: methodRefs size = self numOfCallsExampleModule. "postcondition" pcc enableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithCallIntoModule: nil forClasses: {self class}. self assert: (methodRefs size = 2 and: [| methodCoreStrings | methodCoreStrings := methodRefs collect: [:mRef | mRef methodSymbol allButFirst asString]. (methodCoreStrings includes: 'ExternalCallWithoutModule') and: [methodCoreStrings includes: 'DisabledExternalCallWithoutModule']])! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:36'! testMethodsWithCallX | methodRefs | self avoidSlowTest ifTrue: [^ self]. methodRefs := pcc methodsWithCall: self singularCallName. self assert: methodRefs size = 1! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:34'! testMethodsWithCallXIntoModule | methodRefs | self avoidSlowTest ifTrue: [^ self]. methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameWithSingularCallName. self assert: methodRefs size = 1. methodRefs := pcc methodsWithCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. self assert: methodRefs isEmpty! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:04'! testMethodsWithDisabledCallIntoModule | methodRefs | self avoidSlowTest ifTrue: [^ self]. "precondition: all enabled" pcc disableCallIn: self methodRefsToExampleModule first. methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName. self assert: methodRefs size = 1. "postcondition" pcc enableCallIn: self methodRefsToExampleModule first! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:37'! testMethodsWithDisabledCallIntoModuleForClass "precondition: all enabled" | methodRefs | self methodRefsToExampleModule do: [:ref | pcc disableCallIn: ref]. methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClass: self class. self assert: methodRefs size = self numOfCallsExampleModule. "postcondition" self methodRefsToExampleModule do: [:ref | pcc enableCallIn: ref]. methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClass: self class. self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! testMethodsWithDisabledCallIntoModuleForClasses "precondition: all enabled" | methodRefs | self methodRefsToExampleModule do: [:ref | pcc disableCallIn: ref]. methodRefs := pcc methodsWithDisabledCallIntoModule: self exampleModuleName forClasses: {self class}. self assert: methodRefs size = self numOfCallsExampleModule. "postcondition" self methodRefsToExampleModule do: [:ref | pcc enableCallIn: ref]. methodRefs := pcc methodsWithDisabledCallIntoModule: nil forClasses: {self class}. self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'DisabledExternalCallWithoutModule')! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:38'! testMethodsWithDisabledCallX | methodRefs | self avoidSlowTest ifTrue: [^ self]. "precondition: all enabled" pcc disableCallIn: self singularCallRef. methodRefs := pcc methodsWithDisabledCall: self singularCallName. self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName). "postcondition" pcc enableCallIn: self singularCallRef! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 23:42'! testMethodsWithDisabledCallXIntoModule "precondition: all enabled" | methodRefs | self avoidSlowTest ifTrue: [^ self]. "precondition: all enabled" pcc disableCallIn: self singularCallRef. methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName. self assert: methodRefs size = 1. methodRefs := pcc methodsWithDisabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. self assert: methodRefs isEmpty. "postcondition" pcc enableCallIn: self singularCallRef! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:13'! testMethodsWithEnabledCall | methodRefs | methodRefs := pcc methodsWithEnabledCall. self assert: methodRefs size > 0! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'! testMethodsWithEnabledCallIntoModule | methodRefs | methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName. self assert: methodRefs size = self numOfCallsExampleModule! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/14/2004 22:43'! testMethodsWithEnabledCallIntoModuleForClass "precondition: all enabled" | methodRefs | methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class. self assert: methodRefs size = self numOfCallsExampleModule. methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClass: self class. self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:12'! testMethodsWithEnabledCallIntoModuleForClasses "precondition: all enabled" | methodRefs | methodRefs := pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClasses: {self class}. self assert: methodRefs size = self numOfCallsExampleModule. methodRefs := pcc methodsWithEnabledCallIntoModule: nil forClasses: {self class}. self assert: methodRefs size = 1 & (methodRefs first methodSymbol allButFirst = 'ExternalCallWithoutModule')! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:16'! testMethodsWithEnabledCallX | methodRefs | methodRefs := pcc methodsWithEnabledCall: self singularCallName. self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self singularCallName)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 07:17'! testMethodsWithEnabledCallXIntoModule "precondition: all enabled" | methodRefs | methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameWithSingularCallName. self assert: methodRefs size = 1. methodRefs := pcc methodsWithEnabledCall: self singularCallName intoModule: self moduleNameNotWithSingularCallName. self assert: methodRefs isEmpty! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:07'! testMethodsWithFailedCall | methodRefs | methodRefs := pcc methodsWithFailedCall. self assert: methodRefs size >= 1 & ((methodRefs select: [:mRef | mRef methodSymbol = self failedCallSelector]) size = 1)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:11'! testMethodsWithFailedCallForClass | methodRefs | methodRefs := pcc methodsWithFailedCallForClass: self class. self assert: methodRefs size = 1 & (methodRefs asArray first methodSymbol = self failedCallSelector)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 02:54'! testMethodsWithFailedCallIntoModule | methodRefs | methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName. self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/15/2004 03:13'! testMethodsWithFailedCallIntoModuleForClass | methodRefs | methodRefs := pcc methodsWithFailedCallIntoModule: self failModuleName forClass: self class. self assert: methodRefs size = 1 & (methodRefs first methodSymbol = self failedCallSelector)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:58'! testSwitchPrimCallOffOn | res | pcc disableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class. self should: [self perform: self realExternalCallOrPrimitiveFailedSelector] raise: TestResult error. pcc enableCallInMethod: self realExternalCallOrPrimitiveFailedSelector class: self class. self shouldnt: [res := self perform: self realExternalCallOrPrimitiveFailedSelector] raise: TestResult error. self assert: res isString! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! testSwitchStored | refs | "all enabled, precondition" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. refs := self methodRefsToExampleModule. "fill cache" refs do: [:ref | pcc disableCallIn: ref]. "enable one" pcc enableCallIn: refs first. self assert: (pcc existsEnabledCallIn: refs first). self assert: (pcc existsDisabledCallIn: refs second). "switching" pcc switchStored. "now the checks go vice versa" self assert: (pcc existsDisabledCallIn: refs first). self assert: (pcc existsEnabledCallIn: refs second). pcc enableCallIn: refs first. self assert: (pcc existsEnabledCallIn: refs first)! ! !PrimCallControllerAbstractTest methodsFor: 'tests' stamp: 'sr 6/11/2004 06:46'! testTryCaches | refs | "all enabled, precondition" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. refs := self methodRefsToExampleModule. "fill cache" refs do: [:ref | pcc disableCallIn: ref]. "try caches" pcc enableDisabled. "all enabled" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule. pcc disableEnabled. self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = 0. pcc enableDisabled. "all enabled, postcondition" self assert: (pcc methodsWithEnabledCallIntoModule: self exampleModuleName forClass: self class) size = self numOfCallsExampleModule! ! !PrimCallControllerAbstractTest commentStamp: 'sr 6/15/2004 19:20' prior: 0! PrimCallController tests. Tests are here, but this class isAbstract and won't be tested. Tests are done in the subclasses, which inherit the tests here. If you want to perform some more very slow tests, change doNotMakeSlowTestsFlag in >>setUp.! !PrimCallControllerAbstractTest class methodsFor: 'Testing' stamp: 'sr 6/7/2004 11:59'! isAbstract ^ true! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'! num ^ primitiveNum! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:23'! num: n primitiveNum _ n! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/12/2003 12:26'! printOn: aStream aStream nextPutAll: 'primitive '; print: primitiveNum! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/19/2003 22:06'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ primitiveNum. primIndex = 0 ifTrue: [^ self]. primIndex = 120 ifTrue: [ "External call spec" ^ aStream print: spec]. aStream nextPutAll: '<primitive: '. primIndex = 117 ifTrue: [ primDecl _ spec. aStream nextPut: $'; nextPutAll: (primDecl at: 2); nextPut: $'. (primDecl at: 1) ifNotNil: [ aStream nextPutAll: ' module: '; nextPut: $'; nextPutAll: (primDecl at: 1); nextPut: $']. ] ifFalse: [aStream print: primIndex]. aStream nextPut: $>. (primIndex ~= 117 and: [primIndex ~= 120]) ifTrue: [ Smalltalk at: #Interpreter ifPresent: [:cls | aStream nextPutAll: ' "', ((cls classPool at: #PrimitiveTable) at: primIndex + 1) , '" ' ]. ]. ! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 3/19/2003 22:02'! sourceText ^ String streamContents: [:stream | self printPrimitiveOn: stream]! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:37'! spec ^ spec! ! !PrimitiveNode methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:30'! spec: literal spec _ literal! ! !PrimitiveNode commentStamp: 'ajh 3/24/2003 21:35' prior: 0! I represent a primitive. I am more than just a number if I am a named primitive. Structure: num <Integer> Primitive number. spec <Object> Stored in first literal when num is 117 or 120. ! !PrimitiveNode class methodsFor: 'as yet unclassified' stamp: 'ajh 7/14/2001 12:47'! null ^ self new num: 0! ! !PrintComponent methodsFor: 'menu commands' stamp: 'dgd 2/21/2003 23:04'! accept "Inform the model of text to be accepted, and return true if OK." | textToAccept | self canDiscardEdits ifTrue: [^self flash]. setTextSelector isNil ifTrue: [^self]. textToAccept := textMorph asText. model perform: setTextSelector with: (Compiler evaluate: textToAccept logged: false). self setText: textToAccept. self hasUnacceptedEdits: false! ! !PrintComponent methodsFor: 'model access' stamp: 'dgd 2/21/2003 23:04'! getText "Retrieve the current model text" getTextSelector isNil ifTrue: [^Text new]. ^(model perform: getTextSelector) printString asText! ! !PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'! initialize landscapeFlag _ false. scaleToFitPage _ false. drawAsBitmapFlag _ false. ! ! !PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'! scaleToFitPage ^scaleToFitPage ifNil: [false]! ! !PrintSpecifications methodsFor: 'as yet unclassified' stamp: 'RAA 2/22/2001 07:35'! scaleToFitPage: aBoolean scaleToFitPage _ aBoolean! ! !Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:00'! primitiveResume "Primitive. Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Fail if the receiver is already waiting in a queue (in a Semaphore or ProcessScheduler). Essential. See Object documentation whatIsAPrimitive." <primitive: 87> self primitiveFailed! ! !Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:51'! primitiveSuspend "Primitive. Stop the process that self represents in such a way that it can be restarted at a later time (by sending #resume). ASSUMES self is the active process. Essential. See Object documentation whatIsAPrimitive." <primitive: 88> self primitiveFailed! ! !Process methodsFor: 'changing process state' stamp: 'tpr 2/14/2001 10:03'! resume "Allow the process that the receiver represents to continue. Put the receiver in line to become the activeProcess. Check for a nil suspendedContext, which indicates a previously terminated Process that would cause a vm crash if the resume attempt were permitted" suspendedContext ifNil: [^ self primitiveFailed]. ^ self primitiveResume! ! !Process methodsFor: 'changing process state' stamp: 'ajh 1/23/2003 23:02'! run "Suspend current process and execute self instead" | proc | proc _ Processor activeProcess. [ proc suspend. self resume. ] forkAt: Processor highestPriority! ! !Process methodsFor: 'changing process state' stamp: 'ajh 7/20/2003 22:47'! suspend "Stop the process that the receiver represents in such a way that it can be restarted at a later time (by sending the receiver the message resume). If the receiver represents the activeProcess, suspend it. Otherwise remove the receiver from the list of waiting processes." self isActiveProcess ifTrue: [ myList _ nil. self primitiveSuspend. ] ifFalse: [ myList ifNotNil: [ myList remove: self ifAbsent: []. myList _ nil]. ] ! ! !Process methodsFor: 'changing process state' stamp: 'nk 6/21/2004 14:07'! terminate "Stop the process that the receiver represents forever. Unwind to execute pending ensure:/ifCurtailed: blocks before terminating." | ctxt unwindBlock | self isActiveProcess ifTrue: [ ctxt _ thisContext. [ ctxt _ ctxt findNextUnwindContextUpTo: nil. ctxt isNil ] whileFalse: [ unwindBlock _ ctxt tempAt: 1. unwindBlock ifNotNil: [ ctxt tempAt: 1 put: nil. thisContext terminateTo: ctxt. unwindBlock value]. ]. thisContext terminateTo: nil. myList _ nil. self primitiveSuspend. ] ifFalse: [ myList ifNotNil: [ myList remove: self ifAbsent: []. myList _ nil]. suspendedContext ifNotNil: [ ctxt _ self popTo: suspendedContext bottomContext. ctxt == suspendedContext bottomContext ifFalse: [ self debug: ctxt title: 'Unwind error during termination']]. ]. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 16:14'! activateReturn: aContext value: value "Activate 'aContext return: value', so execution will return to aContext's sender" ^ suspendedContext _ suspendedContext activateReturn: aContext value: value! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:13'! complete: aContext "Run self until aContext is popped or an unhandled error is raised. Return self's new top context, unless an unhandled error was raised then return the signaler context (rather than open a debugger)." | ctxt pair error | ctxt _ suspendedContext. suspendedContext _ nil. "disable this process while running its stack in active process below" pair _ ctxt runUntilErrorOrReturnFrom: aContext. suspendedContext _ pair first. error _ pair second. error ifNotNil: [^ error signalerContext]. ^ suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:16'! completeStep: aContext "Resume self until aContext is on top, or if already on top, complete next step" | callee | self suspendedContext == aContext ifFalse: [ ^ self complete: (self calleeOf: aContext)]. callee _ self step. callee == aContext ifTrue: [^ callee]. aContext isDead ifTrue: [^ self suspendedContext]. "returned" ^ self complete: callee "finish send"! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 21:43'! completeTo: aContext "Resume self until aContext is on top" self suspendedContext == aContext ifTrue: [^ aContext]. ^ self complete: (self calleeOf: aContext)! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! popTo: aContext "Pop self down to aContext by remote returning from aContext's callee. Unwind blocks will be executed on the way. This is done by pushing a new context on top which executes 'aContext callee return' then resuming self until aContext is reached. This way any errors raised in an unwind block will get handled by senders in self and not by senders in the activeProcess. If an unwind block raises an error that is not handled then the popping stops at the error and the signalling context is returned, othewise aContext is returned." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee _ (self calleeOf: aContext) ifNil: [^ aContext]. "aContext is on top" ^ self return: callee value: callee receiver! ! !Process methodsFor: 'changing suspended state' stamp: 'gk 12/18/2003 13:09'! popTo: aContext value: aValue "Replace the suspendedContext with aContext, releasing all contexts between the currently suspendedContext and it." | callee | self == Processor activeProcess ifTrue: [^ self error: 'The active process cannot pop contexts']. callee _ (self calleeOf: aContext) ifNil: [^ self]. "aContext is on top" self return: callee value: aValue! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 20:40'! restartTop "Rollback top context and replace with new method. Assumes self is suspended" suspendedContext privRefresh! ! !Process methodsFor: 'changing suspended state' stamp: 'nk 7/10/2004 11:16'! restartTopWith: method "Rollback top context and replace with new method. Assumes self is suspended" method isQuick ifTrue: [ self popTo: suspendedContext sender ] ifFalse: [ suspendedContext privRefreshWith: method ]. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 3/5/2004 03:26'! return: aContext value: value "Pop thread down to aContext's sender. Execute any unwind blocks on the way. See #popTo: comment and #runUntilErrorOrReturnFrom: for more details." suspendedContext == aContext ifTrue: [ ^ suspendedContext _ aContext return: value from: aContext]. self activateReturn: aContext value: value. ^ self complete: aContext. ! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! step ^ suspendedContext _ suspendedContext step! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/31/2003 14:45'! step: aContext "Resume self until aContext is on top, or if already on top, do next step" ^ self suspendedContext == aContext ifTrue: [self step] ifFalse: [self complete: (self calleeOf: aContext)]! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/23/2003 22:06'! stepToCallee "Step until top context changes" | ctxt | ctxt _ suspendedContext. [ctxt == suspendedContext] whileTrue: [ suspendedContext _ suspendedContext step]. ^ suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 7/18/2003 22:13'! stepToHome: aContext "Resume self until the home of top context is aContext. Top context may be a block context." | home ctxt | home _ aContext home. [ ctxt _ self step. home == ctxt home. ] whileFalse: [ home isDead ifTrue: [^ self suspendedContext]. ]. ^ self suspendedContext! ! !Process methodsFor: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! stepToSendOrReturn ^ suspendedContext _ suspendedContext stepToSendOrReturn! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 14:53'! calleeOf: aContext "Return the context whose sender is aContext. Return nil if aContext is on top. Raise error if aContext is not in process chain." suspendedContext == aContext ifTrue: [^ nil]. ^ (suspendedContext findContextSuchThat: [:c | c sender == aContext]) ifNil: [self error: 'aContext not in process chain']! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/27/2003 18:39'! copyStack ^ self copy install: suspendedContext copyStack! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 19:44'! isActiveProcess ^ self == Processor activeProcess! ! !Process methodsFor: 'accessing' stamp: 'ajh 3/4/2004 22:18'! isTerminated self isActiveProcess ifTrue: [^ false]. ^ suspendedContext isNil or: [ suspendedContext == suspendedContext bottomContext and: [ suspendedContext pc > suspendedContext startpc]]! ! !Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! name ^name ifNil: [ self hash asString forceTo: 5 paddingStartWith: $ ]! ! !Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! name: aString name _ aString! ! !Process methodsFor: 'accessing' stamp: 'ar 7/8/2001 17:04'! priority: anInteger "Set the receiver's priority to anInteger." (anInteger >= Processor lowestPriority and:[anInteger <= Processor highestPriority]) ifTrue: [priority _ anInteger] ifFalse: [self error: 'Invalid priority: ', anInteger printString]! ! !Process methodsFor: 'printing' stamp: 'svp 12/5/2002 14:45'! browserPrintStringWith: anObject | stream | stream _ WriteStream on: (String new: 100). stream nextPut: $(. priority printOn: stream. self isSuspended ifTrue: [stream nextPut: $s]. stream nextPutAll: ') '. stream nextPutAll: self name. stream nextPut: $:. stream space. stream nextPutAll: anObject asString. ^ stream contents! ! !Process methodsFor: 'printing' stamp: 'ajh 10/2/2001 14:36'! longPrintOn: stream | ctxt | super printOn: stream. stream cr. ctxt _ self suspendedContext. [ctxt == nil] whileFalse: [ stream space. ctxt printOn: stream. stream cr. ctxt _ ctxt sender. ]. ! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:54'! debug: context title: title "Open debugger on self with context shown on top" self debug: context title: title full: false. ! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:53'! debug: context title: title full: bool "Open debugger on self with context shown on top" | topCtxt | topCtxt _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. (topCtxt hasContext: context) ifFalse: [^ self error: 'context not in process']. Debugger openOn: self context: context label: title contents: nil fullView: bool. ! ! !Process methodsFor: 'debugging' stamp: 'ajh 7/20/2003 23:55'! debugWithTitle: title "Open debugger on self" | context | context _ self isActiveProcess ifTrue: [thisContext] ifFalse: [self suspendedContext]. self debug: context title: title full: true. ! ! !Process methodsFor: 'signaling' stamp: 'svp 9/19/2003 18:41'! pvtSignal: anException list: aList "Private. This method is used to signal an exception from another process...the receiver must be the active process. If the receiver was previously waiting on a Semaphore, then return the process to the waiting state after signaling the exception and if the Semaphore has not been signaled in the interim" "Since this method is not called in a normal way, we need to take care that it doesn't directly return to the caller (because I believe that could have the potential to push an unwanted object on the caller's stack)." | blocker | self isActiveProcess ifFalse: [^self]. anException signal. blocker := Semaphore new. [self suspend. suspendedContext := suspendedContext swapSender: nil. aList class == Semaphore ifTrue: [aList isSignaled ifTrue: [aList wait. "Consume the signal that would have restarted the receiver" self resume] ifFalse: ["Add us back to the Semaphore's list (and remain blocked)" myList := aList. aList add: self]] ifFalse: [self resume]] fork. blocker wait. ! ! !Process methodsFor: 'signaling' stamp: 'ar 2/23/2005 11:48'! signalException: anException "Signal an exception in the receiver process...if the receiver is currently suspended, the exception will get signaled when the receiver is resumed. If the receiver is blocked on a Semaphore, it will be immediately re-awakened and the exception will be signaled; if the exception is resumed, then the receiver will return to a blocked state unless the blocking Semaphore has excess signals" "If we are the active process, go ahead and signal the exception" self isActiveProcess ifTrue: [^anException signal]. "Add a new method context to the stack that will signal the exception" suspendedContext := MethodContext sender: suspendedContext receiver: self method: (self class methodDict at: #pvtSignal:list:) arguments: (Array with: anException with: myList). "If we are on a list to run, then suspend and restart the receiver (this lets the receiver run if it is currently blocked on a semaphore). If we are not on a list to be run (i.e. this process is suspended), then when the process is resumed, it will signal the exception" myList ifNotNil: [self suspend; resume].! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'nk 2/16/2001 13:39'! selectedMethod ^ methodText ifNil: [methodText _ selectedContext ifNil: [''] ifNotNil: [| pcRange | methodText _ [ selectedContext sourceCode ] ifError: [ :err :rcvr | 'error getting method text' ]. pcRange _ self pcRange. methodText asText addAttribute: TextColor red from: pcRange first to: pcRange last; addAttribute: TextEmphasis bold from: pcRange first to: pcRange last]]! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'ajh 9/7/2002 21:22'! selectedSelector "Answer the class in which the currently selected context's method was found." ^ selectedSelector ifNil: [selectedSelector _ selectedContext receiver ifNil: [| who | who _ selectedContext method. selectedClass _ who first. who last] ifNotNil: [selectedContext methodSelector]]! ! !ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 10/31/2001 10:54'! initialize methodText _ ''. stackListIndex _ 0. searchString _ ''. lastUpdate _ 0. startedCPUWatcher _ Preferences cpuWatcherEnabled and: [ self startCPUWatcher ]. self updateProcessList; processListIndex: 1! ! !ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 3/14/2001 09:26'! startCPUWatcher "Answers whether I started the CPUWatcher" | pw | pw _ Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. pw ifNotNil: [ pw isMonitoring ifFalse: [ pw startMonitoringPeriod: 5 rate: 100 threshold: 0.85. self setUpdateCallbackAfter: 7. ^true ] ]. ^false ! ! !ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 3/14/2001 09:26'! stopCPUWatcher | pw | pw _ Smalltalk at: #CPUWatcher ifAbsent: [ ^self ]. pw ifNotNil: [ pw stopMonitoring. self updateProcessList. startedCPUWatcher _ false. "so a manual restart won't be killed later" ] ! ! !ProcessBrowser methodsFor: 'initialize-release' stamp: 'nk 3/14/2001 08:03'! windowIsClosing startedCPUWatcher ifTrue: [ CPUWatcher stopMonitoring ]! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 17:02'! changePriority | str newPriority nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [PopUpMenu inform: 'Nope, won''t change priority of ' , nameAndRules first. ^ self]. str _ FillInTheBlank request: 'New priority' initialAnswer: selectedProcess priority asString. newPriority _ str asNumber asInteger. newPriority ifNil: [^ self]. (newPriority < 1 or: [newPriority > Processor highestPriority]) ifTrue: [PopUpMenu inform: 'Bad priority'. ^ self]. self class setProcess: selectedProcess toPriority: newPriority. self updateProcessList! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 16:37'! debugProcess | nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules third ifFalse: [PopUpMenu inform: 'Nope, won''t debug ' , nameAndRules first. ^ self]. self class debugProcess: selectedProcess.! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 2/22/2005 15:26'! inspectPointers | tc pointers | selectedProcess ifNil: [^self]. tc := thisContext. pointers := PointerFinder pointersTo: selectedProcess except: { self processList. tc. self}. pointers isEmpty ifTrue: [^self]. OrderedCollectionInspector openOn: pointers withEvalPane: false withLabel: 'Objects pointing to ' , selectedProcess browserPrintString! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:35'! nameAndRulesFor: aProcess "Answer a nickname and two flags: allow-stop, and allow-debug" aProcess == autoUpdateProcess ifTrue: [ ^{'my auto-update process'. true. true} ]. ^self class nameAndRulesFor: aProcess ! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:23'! resumeProcess selectedProcess ifNil: [^ self]. self class resumeProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:21'! suspendProcess | nameAndRules | selectedProcess isSuspended ifTrue: [^ self]. nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [PopUpMenu inform: 'Nope, won''t suspend ' , nameAndRules first. ^ self]. self class suspendProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process actions' stamp: 'nk 3/8/2001 13:25'! terminateProcess | nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. nameAndRules second ifFalse: [PopUpMenu inform: 'Nope, won''t kill ' , nameAndRules first. ^ self]. self class terminateProcess: selectedProcess. self updateProcessList! ! !ProcessBrowser methodsFor: 'process list' stamp: 'nk 6/30/2004 07:00'! prettyNameForProcess: aProcess | nameAndRules | aProcess ifNil: [ ^'<nil>' ]. nameAndRules _ self nameAndRulesFor: aProcess. ^ aProcess browserPrintStringWith: nameAndRules first! ! !ProcessBrowser methodsFor: 'process list' stamp: 'LC 1/7/2002 16:35'! processListMenu: menu | pw | selectedProcess ifNotNil: [| nameAndRules | nameAndRules _ self nameAndRulesForSelectedProcess. menu addList: {{'inspect (i)'. #inspectProcess}. {'explore (I)'. #exploreProcess}. {'inspect Pointers (P)'. #inspectPointers}}. (Smalltalk includesKey: #PointerFinder) ifTrue: [ menu add: 'chase pointers (c)' action: #chasePointers. ]. nameAndRules second ifTrue: [menu add: 'terminate (t)' action: #terminateProcess. selectedProcess isSuspended ifTrue: [menu add: 'resume (r)' action: #resumeProcess] ifFalse: [menu add: 'suspend (s)' action: #suspendProcess]]. nameAndRules third ifTrue: [menu addList: {{'change priority (p)'. #changePriority}. {'debug (d)'. #debugProcess}}]. menu addList: {{'profile messages (m)'. #messageTally}}. (selectedProcess suspendingList isKindOf: Semaphore) ifTrue: [menu add: 'signal Semaphore (S)' action: #signalSemaphore]. menu add: 'full stack (k)' action: #moreStack. menu addLine]. menu addList: {{'find context... (f)'. #findContext}. {'find again (g)'. #nextContext}}. menu addLine. menu add: (self isAutoUpdating ifTrue: ['turn off auto-update (a)'] ifFalse: ['turn on auto-update (a)']) action: #toggleAutoUpdate. menu add: 'update list (u)' action: #updateProcessList. pw _ Smalltalk at: #CPUWatcher ifAbsent: []. pw ifNotNil: [ menu addLine. pw isMonitoring ifTrue: [ menu add: 'stop CPUWatcher' action: #stopCPUWatcher ] ifFalse: [ menu add: 'start CPUWatcher' action: #startCPUWatcher ] ]. ^ menu! ! !ProcessBrowser methodsFor: 'process list' stamp: 'nk 6/21/2004 09:59'! processNameList "since processList is a WeakArray, we have to strengthen the result" | pw tally | pw _ Smalltalk at: #CPUWatcher ifAbsent: [ ]. tally _ pw ifNotNil: [ pw current ifNotNil: [ pw current tally ] ]. ^ (processList asOrderedCollection copyWithout: nil) collect: [:each | | percent | percent _ tally ifNotNil: [ ((((tally occurrencesOf: each) * 100.0 / tally size) roundTo: 1) asString padded: #left to: 2 with: $ ), '% ' ] ifNil: [ '' ]. percent, (self prettyNameForProcess: each) ] ! ! !ProcessBrowser methodsFor: 'process list' stamp: 'ajh 7/21/2003 10:11'! updateProcessList | oldSelectedProcess newIndex now | now _ Time millisecondClockValue. now - lastUpdate < 500 ifTrue: [^ self]. "Don't update too fast" lastUpdate _ now. oldSelectedProcess _ selectedProcess. processList _ selectedProcess _ selectedSelector _ nil. Smalltalk garbageCollectMost. "lose defunct processes" processList _ Process allSubInstances reject: [:each | each isTerminated]. processList _ processList sortBy: [:a :b | a priority >= b priority]. processList _ WeakArray withAll: processList. newIndex _ processList indexOf: oldSelectedProcess ifAbsent: [0]. self changed: #processNameList. self processListIndex: newIndex! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 3/8/2004 13:09'! messageTally | secString secs | secString _ FillInTheBlank request: 'Profile for how many seconds?' initialAnswer: '4'. secs _ secString asNumber asInteger. (secs isNil or: [secs isZero]) ifTrue: [^ self]. [ TimeProfileBrowser spyOnProcess: selectedProcess forMilliseconds: secs * 1000 ] forkAt: selectedProcess priority + 1.! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/4/2003 19:55'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." | i methodNode pc end tempNames | methodText isEmptyOrNil ifTrue: [^ 1 to: 0]. sourceMap == nil ifTrue: [self selectedClass == #unknown ifTrue: [^ 1 to: 0]. [[methodNode _ self selectedClass compilerClass new parse: methodText in: self selectedClass notifying: self ] on: Warning do: [:ex | methodText _ ('(syntax error) ' , ex description , String cr , methodText) asText. ex return]] on: Error do: [:ex | methodText _ ('(parse error) ' , ex description , String cr , methodText) asText. ex return]. methodNode ifNil: [sourceMap _ nil. ^ 1 to: 0]. sourceMap _ methodNode sourceMap. tempNames _ methodNode tempNames. selectedContext method cacheTempNames: tempNames]. (sourceMap size = 0 or: [ selectedContext isDead ]) ifTrue: [^ 1 to: 0]. pc _ selectedContext pc. pc _ pc - 2. i _ sourceMap indexForInserting: (Association key: pc value: nil). i < 1 ifTrue: [^ 1 to: 0]. i > sourceMap size ifTrue: [end _ sourceMap inject: 0 into: [:prev :this | prev max: this value last]. ^ end + 1 to: end]. ^ (sourceMap at: i) value! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! isAutoUpdatingPaused ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended ]! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:20'! pauseAutoUpdate self isAutoUpdating ifTrue: [ autoUpdateProcess suspend ]. self updateProcessList! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 3/14/2001 09:08'! setUpdateCallbackAfter: seconds deferredMessageRecipient ifNotNil: [ | d | d _ Delay forSeconds: seconds. [ d wait. d _ nil. deferredMessageRecipient addDeferredUIMessage: [self updateProcessList] ] fork ]! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:21'! startAutoUpdate self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ]. self isAutoUpdating ifFalse: [| delay | delay _ Delay forSeconds: 2. autoUpdateProcess _ [[self hasView] whileTrue: [delay wait. deferredMessageRecipient ifNotNil: [ deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]] ifNil: [ self updateProcessList ]]. autoUpdateProcess _ nil] fork]. self updateProcessList! ! !ProcessBrowser methodsFor: 'updating' stamp: 'nk 6/18/2003 07:22'! stopAutoUpdate autoUpdateProcess ifNotNil: [ autoUpdateProcess terminate. autoUpdateProcess _ nil]. self updateProcessList! ! !ProcessBrowser methodsFor: 'views' stamp: 'sw 6/13/2001 19:39'! asPrototypeInWindow "Create a pluggable version of me, answer a window" | window aTextMorph | window _ (SystemWindow labelled: 'later') model: self. window addMorph: ((PluggableListMorph on: self list: #processNameList selected: #processListIndex changeSelected: #processListIndex: menu: #processListMenu: keystroke: #processListKey:from:) enableDragNDrop: false) frame: (0 @ 0 extent: 0.5 @ 0.5). window addMorph: ((PluggableListMorph on: self list: #stackNameList selected: #stackListIndex changeSelected: #stackListIndex: menu: #stackListMenu: keystroke: #stackListKey:from:) enableDragNDrop: false) frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). aTextMorph _ PluggableTextMorph on: self text: #selectedMethod accept: nil readSelection: nil menu: nil. window addMorph: aTextMorph frame: (0 @ 0.5 corner: 1 @ 1). window setLabel: 'Process Browser'. ^ window! ! !ProcessBrowser methodsFor: 'views' stamp: 'nk 3/14/2001 09:04'! openAsMVC "Create a pluggable version of me, answer a window" | window processListView stackListView methodTextView | window _ StandardSystemView new model: self controller: (deferredMessageRecipient _ DeferredActionStandardSystemController new). window borderWidth: 1. processListView _ PluggableListView on: self list: #processNameList selected: #processListIndex changeSelected: #processListIndex: menu: #processListMenu: keystroke: #processListKey:from:. processListView window: (0 @ 0 extent: 300 @ 200). window addSubView: processListView. stackListView _ PluggableListView on: self list: #stackNameList selected: #stackListIndex changeSelected: #stackListIndex: menu: #stackListMenu: keystroke: #stackListKey:from:. stackListView window: (300 @ 0 extent: 300 @ 200). window addSubView: stackListView toRightOf: processListView. methodTextView _ PluggableTextView on: self text: #selectedMethod accept: nil readSelection: nil menu: nil. methodTextView askBeforeDiscardingEdits: false. methodTextView window: (0 @ 200 corner: 600 @ 400). window addSubView: methodTextView below: processListView. window setUpdatablePanesFrom: #(#processNameList #stackNameList ). window label: 'Process Browser'. window minimumSize: 300 @ 200. window subViews do: [:each | each controller]. window controller open. startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ]. ^ window! ! !ProcessBrowser methodsFor: 'views' stamp: 'nk 3/14/2001 09:04'! openAsMorph "Create a pluggable version of me, answer a window" | window aTextMorph | window _ (SystemWindow labelled: 'later') model: self. deferredMessageRecipient _ WorldState. window addMorph: ((PluggableListMorph on: self list: #processNameList selected: #processListIndex changeSelected: #processListIndex: menu: #processListMenu: keystroke: #processListKey:from:) enableDragNDrop: false) frame: (0 @ 0 extent: 0.5 @ 0.5). window addMorph: ((PluggableListMorph on: self list: #stackNameList selected: #stackListIndex changeSelected: #stackListIndex: menu: #stackListMenu: keystroke: #stackListKey:from:) enableDragNDrop: false) frame: (0.5 @ 0.0 extent: 0.5 @ 0.5). aTextMorph _ PluggableTextMorph on: self text: #selectedMethod accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0 @ 0.5 corner: 1 @ 1). window setUpdatablePanesFrom: #(#processNameList #stackNameList ). (window setLabel: 'Process Browser') openInWorld. startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ]. ^ window! ! !ProcessBrowser commentStamp: '<historical>' prior: 0! Change Set: ProcessBrowser Date: 14 March 2000 Author: Ned Konz email: ned@bike-nomad.com This is distributed under the Squeak License. Added 14 March: CPUWatcher integration automatically start and stop CPUWatcher added CPUWatcher to process list menu Added 29 October: MVC version 2.8, 2.7 compatibility rearranged menus added pointer inspection and chasing added suspend/resume recognized more well-known processes misc. bug fixes Added 26 October: highlight pc in source code Added 27 October: added 'signal semaphore' added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu added 'find context', 'next context' to process list menu added 'change priority' and 'debug' choices to process list menu 27 October mods by Bob Arning: alters process display in Ned's ProcessBrowser to - show process priority - drop 'a Process in' that appears on each line - show in priority order - prettier names for known processes - fix to Utilities to forget update downloading process when it ends (1 less dead process) - correct stack dump for the active process ! !ProcessBrowser class methodsFor: 'instance creation' stamp: 'nk 3/14/2001 07:53'! open "ProcessBrowser open" "Create and schedule a ProcessBrowser." Smalltalk garbageCollect. ^ Smalltalk isMorphic ifTrue: [ self new openAsMorph ] ifFalse: [ self new openAsMVC ]! ! !ProcessBrowser class methodsFor: 'instance creation' stamp: 'sw 6/13/2001 01:04'! prototypicalToolWindow "Answer a window representing a prototypical instance of the receiver" ^ self new asPrototypeInWindow! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 17:09'! debugProcess: aProcess self resumeProcess: aProcess. aProcess debugWithTitle: 'Interrupted from the Process Browser'. ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 20:11'! isUIProcess: aProcess ^aProcess == (Smalltalk isMorphic ifTrue: [ Project uiProcess ] ifFalse: [ ScheduledControllers activeControllerProcess ])! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 4/12/2004 19:37'! nameAndRulesFor: aProcess "Answer a nickname and two flags: allow-stop, and allow-debug" ^ [aProcess caseOf: { [] -> [{'no process'. false. false}]. [Smalltalk lowSpaceWatcherProcess] -> [{'the low space watcher'. false. false}]. [WeakArray runningFinalizationProcess] -> [{'the WeakArray finalization process'. false. false}]. [Processor activeProcess] -> [{'the UI process'. false. true}]. [Processor backgroundProcess] -> [{'the idle process'. false. false}]. [Sensor interruptWatcherProcess] -> [{'the user interrupt watcher'. false. false}]. [Sensor eventTicklerProcess] -> [{'the event tickler'. false. false}]. [Project uiProcess] -> [{'the inactive Morphic UI process'. false. false}]. [Smalltalk at: #SoundPlayer ifPresent: [:sp | sp playerProcess]] -> [{'the Sound Player'. false. false}]. [ScheduledControllers ifNotNil: [ScheduledControllers activeControllerProcess]] -> [{'the inactive MVC controller process'. false. true}]. [Smalltalk at: #CPUWatcher ifPresent: [:cw | cw currentWatcherProcess]] -> [{'the CPUWatcher'. false. false}]} otherwise: [(aProcess priority = Processor timingPriority and: [aProcess suspendedContext receiver == Delay]) ifTrue: [{'the timer interrupt watcher'. false. false}] ifFalse: [{aProcess suspendedContext asString. true. true}]]] ifError: [:err :rcvr | {aProcess suspendedContext asString. true. true}]! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 2/12/2002 10:09'! resumeProcess: aProcess | priority | priority _ self suspendedProcesses removeKey: aProcess ifAbsent: [aProcess priority]. aProcess priority: priority. aProcess suspendedContext ifNotNil: [ aProcess resume ] ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 17:07'! setProcess: aProcess toPriority: priority | oldPriority | oldPriority _ self suspendedProcesses at: aProcess ifAbsent: [ ]. oldPriority ifNotNil: [ self suspendedProcesses at: aProcess put: priority ]. aProcess priority: priority. ^oldPriority! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'dew 9/16/2001 01:53'! suspendProcess: aProcess | priority | priority _ aProcess priority. self suspendedProcesses at: aProcess put: priority. "Need to take the priority down below the caller's so that it can keep control after signaling the Semaphore" (aProcess suspendingList isKindOf: Semaphore) ifTrue: [aProcess priority: Processor lowestPriority. aProcess suspendingList signal]. [aProcess suspend] on: Error do: [:ex | self suspendedProcesses removeKey: aProcess]. aProcess priority: priority. ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:25'! terminateProcess: aProcess aProcess ifNotNil: [ self suspendedProcesses removeKey: aProcess ifAbsent: []. aProcess terminate ]. ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:26'! wasProcessSuspendedByProcessBrowser: aProcess ^self suspendedProcesses includesKey: aProcess! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'nk 3/14/2001 08:59'! dumpTallyOnTranscript: tally "tally is from ProcessorScheduler>>tallyCPUUsageFor: Dumps lines with percentage of time, hash of process, and a friendly name" tally sortedCounts do: [ :assoc | | procName | procName _ (self nameAndRulesFor: assoc value) first. Transcript print: (((assoc key / tally size) * 100.0) roundTo: 1); nextPutAll: '% '; print: assoc value identityHash; space; nextPutAll: procName; cr. ]. Transcript flush.! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'nk 3/8/2001 12:49'! tallyCPUUsageFor: seconds "Compute CPU usage using a 10-msec sample for the given number of seconds, then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" "ProcessBrowser tallyCPUUsageFor: 10" ^self tallyCPUUsageFor: seconds every: 10! ! !ProcessBrowser class methodsFor: 'CPU utilization' stamp: 'nk 3/8/2001 18:29'! tallyCPUUsageFor: seconds every: msec "Compute CPU usage using a msec millisecond sample for the given number of seconds, then dump the usage statistics on the Transcript. The UI is free to continue, meanwhile" "ProcessBrowser tallyCPUUsageFor: 10 every: 100" | promise | promise _ Processor tallyCPUUsageFor: seconds every: msec. [ | tally | tally _ promise value. Smalltalk isMorphic ifTrue: [ WorldState addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ] ] ifFalse: [ [ Transcript open ] forkAt: Processor userSchedulingPriority. [ (Delay forSeconds: 1) wait. self dumpTallyOnTranscript: tally ] forkAt: Processor userSchedulingPriority.] ] fork.! ! !ProcessBrowser class methodsFor: 'class initialization' stamp: 'nk 6/18/2003 07:31'! initialize "ProcessBrowser initialize" Browsers ifNil: [ Browsers _ WeakSet new ]. SuspendedProcesses ifNil: [ SuspendedProcesses _ IdentityDictionary new ]. Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self. self registerInFlapsRegistry.! ! !ProcessBrowser class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:22'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(ProcessBrowser prototypicalToolWindow 'Processes' 'A Process Browser shows you all the running processes') forFlapNamed: 'Tools'.]! ! !ProcessBrowser class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'! shutDown Browsers do: [ :ea | ea isAutoUpdating ifTrue: [ ea pauseAutoUpdate ]]! ! !ProcessBrowser class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:32'! startUp Browsers do: [ :ea | ea isAutoUpdatingPaused ifTrue: [ ea startAutoUpdate ]]! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'm 7/28/2003 19:10'! testSchedulerTermination | process sema gotHere sema2 | gotHere := false. sema := Semaphore new. sema2 := Semaphore new. process := [ sema signal. sema2 wait. "will be suspended here" gotHere := true. "e.g., we must *never* get here" ] forkAt: Processor activeProcess priority. sema wait. "until process gets scheduled" process terminate. sema2 signal. Processor yield. "will give process a chance to continue and horribly screw up" self assert: gotHere not. ! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:44'! testUnwindFromActiveProcess | sema process | sema := Semaphore forMutualExclusion. self assert:(sema isSignaled). process := [ sema critical:[ self deny: sema isSignaled. Processor activeProcess terminate. ] ] forkAt: Processor userInterruptPriority. self assert: sema isSignaled.! ! !ProcessTerminateBug methodsFor: 'tests' stamp: 'ar 7/27/2003 19:49'! testUnwindFromForeignProcess | sema process | sema := Semaphore forMutualExclusion. self assert: sema isSignaled. process := [ sema critical:[ self deny: sema isSignaled. sema wait. "deadlock" ] ] forkAt: Processor userInterruptPriority. self deny: sema isSignaled. "This is for illustration only - the BlockCannotReturn cannot be handled here (it's truncated already)" self shouldnt: [process terminate] raise: BlockCannotReturn. self assert: sema isSignaled. ! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 8/22/2001 17:33'! preemptedProcess "Return the process that the currently active process just preempted." | list | activeProcess priority to: 1 by: -1 do:[:priority| list _ quiescentProcessLists at: priority. list isEmpty ifFalse:[^list last]. ]. ^nil "Processor preemptedProcess"! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'ar 7/8/2001 16:21'! waitingProcessesAt: aPriority "Return the list of processes at the given priority level." ^quiescentProcessLists at: aPriority! ! !ProcessorScheduler methodsFor: 'process state change' stamp: 'tpr 4/28/2004 17:53'! yield "Give other Processes at the current priority a chance to run." | semaphore | <primitive: 167> semaphore _ Semaphore new. [semaphore signal] fork. semaphore wait! ! !ProcessorScheduler methodsFor: 'priority names' stamp: 'ar 7/8/2001 17:02'! lowestPriority "Return the lowest priority that is allowed with the scheduler" ^SystemRockBottomPriority! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:56'! nextReadyProcess quiescentProcessLists reverseDo: [ :list | list isEmpty ifFalse: [ | proc | proc _ list first. proc suspendedContext ifNotNil: [ ^proc ]]]. ^nil! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/8/2001 12:48'! tallyCPUUsageFor: seconds "Start a high-priority process that will tally the next ready process for the given number of seconds. Answer a Block that will return the tally (a Bag) after the task is complete" ^self tallyCPUUsageFor: seconds every: 10 ! ! !ProcessorScheduler methodsFor: 'CPU usage tally' stamp: 'nk 3/17/2001 10:06'! tallyCPUUsageFor: seconds every: msec "Start a high-priority process that will tally the next ready process for the given number of seconds. Answer a Block that will return the tally (a Bag) after the task is complete" | tally sem delay endDelay | tally _ IdentityBag new: 200. delay _ Delay forMilliseconds: msec truncated. endDelay _ Delay forSeconds: seconds. endDelay schedule. sem _ Semaphore new. [ [ endDelay isExpired ] whileFalse: [ delay wait. tally add: Processor nextReadyProcess ]. sem signal. ] forkAt: self highestPriority. ^[ sem wait. tally ]! ! !ProcessorScheduler class methodsFor: 'class initialization' stamp: 'ar 7/8/2001 16:39'! initialize SystemRockBottomPriority _ 10. SystemBackgroundPriority _ 20. UserBackgroundPriority _ 30. UserSchedulingPriority _ 40. UserInterruptPriority _ 50. LowIOPriority _ 60. HighIOPriority _ 70. TimingPriority _ 80. "ProcessorScheduler initialize."! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'jm 9/11/97 10:44'! idleProcess "A default background process which is invisible." [true] whileTrue: [self relinquishProcessorForMicroseconds: 1000]! ! !ProgressBarMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:43'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addList: { {'progress color...' translated. #changeProgressColor:}. {'progress value...' translated. #changeProgressValue:}. }! ! !ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'laza 4/6/2004 10:01'! defaultAction (Smalltalk isMorphic and: [Preferences valueOfFlag: #morphicProgressStyle]) ifTrue: [self defaultMorphicAction] ifFalse: [self defaultMVCAction]. ! ! !ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'laza 4/1/2004 12:47'! defaultMVCAction | delta savedArea captionText textFrame barFrame outerFrame result range lastW w | barFrame _ aPoint - (75@10) corner: aPoint + (75@10). captionText _ DisplayText text: progressTitle asText allBold. captionText foregroundColor: Color black backgroundColor: Color white. textFrame _ captionText boundingBox insetBy: -4. textFrame _ textFrame align: textFrame bottomCenter with: barFrame topCenter + (0@2). outerFrame _ barFrame merge: textFrame. delta _ outerFrame amountToTranslateWithin: Display boundingBox. barFrame _ barFrame translateBy: delta. textFrame _ textFrame translateBy: delta. outerFrame _ outerFrame translateBy: delta. savedArea _ Form fromDisplay: outerFrame. Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2). Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2). captionText displayOn: Display at: textFrame topLeft + (4@4). range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" lastW _ 0. [result _ workBlock value: "Supply the bar-update block for evaluation in the work block" [:barVal | w _ ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger. w ~= lastW ifTrue: [ Display fillGray: (barFrame topLeft + (2@2) extent: w@16). lastW _ w]]] ensure: [savedArea displayOn: Display at: outerFrame topLeft]. self resume: result! ! !ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'laza 4/9/2004 10:52'! defaultMorphicAction | result progress | progress _ SystemProgressMorph label: progressTitle min: minVal max: maxVal. [result _ workBlock value: progress] ensure: [SystemProgressMorph close: progress]. self resume: result! ! !ProgressInitiationException class methodsFor: 'signalling' stamp: 'ajh 1/22/2003 23:51'! display: aString at: aPoint from: minVal to: maxVal during: workBlock ^ self new display: aString at: aPoint from: minVal to: maxVal during: workBlock! ! !ProgressInitiationException class methodsFor: 'class initialization' stamp: 'laza 4/7/2004 14:44'! initialize Preferences addPreference: #morphicProgressStyle categories: #(#morphic #performance) default: true balloonHelp: 'This switches between morphic and plain style for progress display'! ! !ProgressMorph methodsFor: 'initialization' stamp: 'dvf 9/17/2003 05:14'! initProgressMorph progress := ProgressBarMorph new. progress borderWidth: 1. progress color: Color white. progress progressColor: Color gray. progress extent: 200 @ 15. ! ! !ProgressMorph methodsFor: 'initialization' stamp: 'nk 4/21/2002 20:06'! setupMorphs | | self initProgressMorph. self layoutPolicy: TableLayout new; listDirection: #topToBottom; cellPositioning: #topCenter; listCentering: #center; hResizing: #shrinkWrap; vResizing: #shrinkWrap; color: Color transparent. self addMorphBack: self labelMorph. self addMorphBack: self subLabelMorph. self addMorphBack: self progress. self borderWidth: 2. self borderColor: Color black. self color: Color veryLightGray. self align: self fullBounds center with: Display boundingBox center ! ! !ProgressMorph methodsFor: 'private' stamp: 'nk 7/12/2003 08:59'! fontOfPointSize: size ^ (TextConstants at: Preferences standardEToysFont familyName ifAbsent: [TextStyle default]) fontOfPointSize: size! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! amount ^amount! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! amount: aNumber amount _ aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:11'! done ^done! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! done: aNumber done _ aNumber! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam ^extra! ! !ProgressNotification methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:12'! extraParam: anObject extra _ anObject! ! !ProgressNotification class methodsFor: 'exceptionInstantiator' stamp: 'ajh 1/22/2003 23:51'! signal: signalerText extra: extraParam "TFEI - Signal the occurrence of an exceptional condition with a specified textual description." | ex | ex := self new. ex extraParam: extraParam. ^ex signal: signalerText! ! !Project methodsFor: 'initialization' stamp: 'mir 7/15/2004 19:07'! initMorphic "Written so that Morphic can still be removed. Note that #initialize is never actually called for a morphic project -- see the senders of this method." Smalltalk verifyMorphicAvailability ifFalse: [^ nil]. changeSet := ChangeSet new. transcript := TranscriptStream new. displayDepth := Display depth. parentProject := CurrentProject. isolatedHead := false. world := PasteUpMorph newWorldForProject: self. Locale switchToID: CurrentProject localeID. self initializeProjectPreferences "Do this *after* a world is installed so that the project will be recognized as a morphic one." ! ! !Project methodsFor: 'initialization' stamp: 'di 4/6/2001 10:30'! initialize "Initialize the project, seting the CurrentProject as my parentProject and initializing my project preferences from those of the CurrentProject" changeSet _ ChangeSet new. transcript _ TranscriptStream new. displayDepth _ Display depth. parentProject _ CurrentProject. isolatedHead _ false. self initializeProjectPreferences ! ! !Project methodsFor: 'initialization' stamp: 'ar 5/16/2001 17:08'! installNewDisplay: extent depth: depth "When entering a new project, install a new Display if necessary." ^Display setExtent: extent depth: depth! ! !Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 21:50'! children "Answer a list of all the subprojects of the receiver" | children | children _ OrderedCollection new. Project allProjects do: [ :p | (self == p parent and: [self ~~ p]) ifTrue: [ children add: p ]]. ^ children " Project topProject children "! ! !Project methodsFor: 'accessing' stamp: 'nk 8/30/2004 08:00'! findProjectView: projectDescription | pName dpName proj | "In this world, find the morph that holds onto the project described by projectDescription. projectDescription can be a project, or the name of a project. The project may be represented by a DiskProxy. The holder morph may be at any depth in the world. Need to fix this if Projects have subclasses, or if a class other than ProjectViewMorph can officially hold onto a project. (Buttons, links, etc) If parent is an MVC world, return the ProjectController." self flag: #bob. "read the comment" pName _ (projectDescription isString) ifTrue: [projectDescription] ifFalse: [projectDescription name]. self isMorphic ifTrue: [world allMorphsDo: [:pvm | pvm class == ProjectViewMorph ifTrue: [ (pvm project class == Project and: [pvm project name = pName]) ifTrue: [^ pvm]. pvm project class == DiskProxy ifTrue: [ dpName _ pvm project constructorArgs first. dpName _ (dpName findTokens: '/') last. dpName _ (Project parseProjectFileName: dpName unescapePercents) first. dpName = pName ifTrue: [^ pvm]]]]] ifFalse: [world scheduledControllers do: [:cont | (cont isKindOf: ProjectController) ifTrue: [ ((proj _ cont model) class == Project and: [proj name = pName]) ifTrue: [^ cont view]. proj class == DiskProxy ifTrue: [ dpName _ proj constructorArgs first. dpName _ (dpName findTokens: '/') last. dpName _ (Project parseProjectFileName: dpName unescapePercents) first. dpName = pName ifTrue: [^ cont view]]]] ]. ^ nil! ! !Project methodsFor: 'accessing' stamp: 'mir 6/22/2001 20:06'! forgetExistingURL self resourceManager makeAllProjectResourcesLocalTo: self resourceUrl. urlList _ nil! ! !Project methodsFor: 'accessing' stamp: 'mir 6/7/2001 16:18'! lastDirectory: aDirectoryOrNil lastDirectory _ aDirectoryOrNil! ! !Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 20:01'! nameAdjustedForDepth "Answer the name of the project, prepended with spaces reflecting the receiver's depth from the top project" " Project current nameAdjustedForDepth " | stream | stream _ WriteStream on: String new. self depth timesRepeat: [2 timesRepeat: [stream nextPut: $ ]]. stream nextPutAll: self name. ^ stream contents! ! !Project methodsFor: 'accessing'! renameTo: newName | oldBase | newName = self name ifFalse: [ oldBase _ self resourceDirectoryName. version _ nil. self resourceManager adjustToRename: self resourceDirectoryName from: oldBase. self changeSet name: newName. ].! ! !Project methodsFor: 'accessing' stamp: 'RAA 5/10/2001 14:57'! setThumbnail: aForm self flag: #bob. "no longer used??" thumbnail _ aForm! ! !Project methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:09'! storeNewPrimaryURL: aURLString | oldResourceUrl | oldResourceUrl _ self resourceUrl. urlList isEmptyOrNil ifTrue: [urlList _ Array new: 1]. urlList at: 1 put: aURLString. self lastDirectory: nil. self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl ! ! !Project methodsFor: 'accessing' stamp: 'jla 5/28/2001 21:51'! withChildrenDo: aBlock "Evaluate the block first with the receiver as argument, then, recursively and depth first, with each of the receiver's children as argument" aBlock value: self. self children do: [:p | p withChildrenDo: [:c | aBlock value: c]]! ! !Project methodsFor: 'menu messages' stamp: 'sw 11/22/2001 08:40'! assureNavigatorPresenceMatchesPreference "Make sure that the current project conforms to the presence/absence of the navigator" | navigator navType wantIt | Smalltalk isMorphic ifFalse: [^ self]. wantIt _ Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator]. navType _ ProjectNavigationMorph preferredNavigator. navigator _ world findA: navType. wantIt ifFalse: [navigator ifNotNil: [navigator delete]] ifTrue: [navigator isNil ifTrue: [(navigator _ navType new) bottomLeft: world bottomLeft; openInWorld: world]]! ! !Project methodsFor: 'menu messages' stamp: 'yo 3/1/2005 12:05'! displayFontProgress "Display progress for fonts" | done b pp | done := false. b := ScriptableButton new. b color: Color yellow. b borderWidth: 1; borderColor: Color black. pp := [ | dots str idx | dots := #(' - ' ' \ ' ' | ' ' / '). idx := 0. [done] whileFalse:[ str := '$ Fixing fonts $ ' translated. str := str copyReplaceTokens: '$' with: (dots atWrap: (idx := idx + 1)) asString. b label: str font: (TextStyle defaultFont emphasized: 1). b extent: 200@50. b center: Display center. b fullDrawOn: Display getCanvas. (Delay forMilliseconds: 250) wait. ]. ] forkAt: Processor userInterruptPriority. ^[done := true]! ! !Project methodsFor: 'menu messages' stamp: 'RAA 5/16/2001 17:50'! doWeWantToRename | want | self hasBadNameForStoring ifTrue: [^true]. (self name beginsWith: 'Unnamed') ifTrue: [^true]. want _ world valueOfProperty: #SuperSwikiRename ifAbsent: [false]. world removeProperty: #SuperSwikiRename. ^want ! ! !Project methodsFor: 'menu messages' stamp: 'yo 2/17/2005 15:07'! enter: returningFlag revert: revertFlag saveForRevert: saveForRevert "Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case. If saveForRevert is true, save the ImageSegment of the project being left. If revertFlag is true, make stubs for the world of the project being left. If revertWithoutAsking is true in the project being left, then always revert." | showZoom recorderOrNil old forceRevert response seg newProcess | (world isKindOf: StringMorph) ifTrue: [ self inform: 'This project is not all here. I will try to load a complete version.' translated. ^self loadFromServer: true "try to get a fresh copy" ]. self isCurrentProject ifTrue: [^ self]. "Check the guards" guards ifNotNil: [guards _ guards reject: [:obj | obj isNil]. guards do: [:obj | obj okayToEnterProject ifFalse: [^ self]]]. CurrentProject world triggerEvent: #aboutToLeaveWorld. forceRevert _ false. CurrentProject rawParameters ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to' translated]] ifNotNil: [saveForRevert ifFalse: [ forceRevert _ CurrentProject projectParameters at: #revertWithoutAsking ifAbsent: [false]]]. forceRevert not & revertFlag ifTrue: [ response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs trueChoice: 'Revert to saved version' translated falseChoice: 'Cancel' translated. response ifFalse: [^ self]]. revertFlag | forceRevert ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [ ^ self inform: 'nothing to revert to' translated]] ifFalse: [ CurrentProject finalExitActions. CurrentProject makeThumbnail. returningFlag == #specialReturn ifTrue: [ProjectHistory forget: CurrentProject. "this guy is irrelevant" Project forget: CurrentProject] ifFalse: [ProjectHistory remember: CurrentProject]]. (revertFlag | saveForRevert | forceRevert) ifFalse: [(Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [self storeToMakeRoom]]. CurrentProject abortResourceLoading. Smalltalk isMorphic ifTrue: [CurrentProject world triggerClosingScripts]. CurrentProject saveProjectPreferences. "Update the display depth and make a thumbnail of the current project" CurrentProject displayDepth: Display depth. old _ CurrentProject. "for later" "Show the project transition. Note: The project zoom is run in the context of the old project, so that eventual errors can be handled accordingly" displayDepth == nil ifTrue: [displayDepth _ Display depth]. self installNewDisplay: Display extent depth: displayDepth. (showZoom _ self showZoom) ifTrue: [ self displayZoom: CurrentProject parent ~~ self]. (world isMorph and: [world hasProperty: #letTheMusicPlay]) ifTrue: [world removeProperty: #letTheMusicPlay] ifFalse: [Smalltalk at: #ScorePlayer ifPresentAndInMemory: [:playerClass | playerClass allSubInstancesDo: [:player | player pause]]]. returningFlag == #specialReturn ifTrue: [ old removeChangeSetIfPossible. "keep this stuff from accumulating" nextProject _ nil ] ifFalse: [ returningFlag ifTrue: [nextProject _ CurrentProject] ifFalse: [previousProject _ CurrentProject]. ]. CurrentProject saveState. CurrentProject isolationHead == self isolationHead ifFalse: [self invokeFrom: CurrentProject]. CurrentProject _ self. self installProjectPreferences. ChangeSet newChanges: changeSet. TranscriptStream newTranscript: transcript. Sensor flushKeyboard. Smalltalk isMorphic ifTrue: [recorderOrNil _ World pauseEventRecorder]. ProjectHistory remember: CurrentProject. world isMorph ifTrue: [World _ world. "Signifies Morphic" world install. world transferRemoteServerFrom: old world. "(revertFlag | saveForRevert | forceRevert) ifFalse: [ (Preferences valueOfFlag: #projectsSentToDisk) ifTrue: [ self storeSomeSegment]]." recorderOrNil ifNotNil: [recorderOrNil resumeIn: world]. world triggerOpeningScripts] ifFalse: [World _ nil. "Signifies MVC" Smalltalk at: #ScheduledControllers put: world]. saveForRevert ifTrue: [ Smalltalk garbageCollect. "let go of pointers" old storeSegment. "result _" old world isInMemory ifTrue: ['Can''t seem to write the project.'] ifFalse: [old projectParameters at: #revertToMe put: old world xxxSegment clone]. 'Project written.']. "original is for coming back in and continuing." revertFlag | forceRevert ifTrue: [ seg clone revert]. "non-cloned one is for reverting again later" self removeParameter: #exportState. "Complete the enter: by launching a new process" world isMorph ifTrue: [ self finalEnterActions. world repairEmbeddedWorlds. world triggerEvent: #aboutToEnterWorld. Project spawnNewProcessAndTerminateOld: true ] ifFalse: [ SystemWindow clearTopWindow. "break external ref to this project" newProcess _ [ ScheduledControllers resetActiveController. "in case of walkback in #restore" showZoom ifFalse: [ScheduledControllers restore]. ScheduledControllers searchForActiveController ] fixTemps newProcess priority: Processor userSchedulingPriority. newProcess resume. "lose the current process and its referenced morphs" Processor terminateActive. ]! ! !Project methodsFor: 'menu messages' stamp: 'sd 5/23/2003 15:16'! enterForEmergencyRecovery "This version of enter invokes an absolute minimum of mechanism. An unrecoverable error has been detected in an isolated project. It is assumed that the old changeSet has already been revoked. No new process gets spawned here. This will happen in the debugger." self isCurrentProject ifTrue: [^ self]. CurrentProject saveState. CurrentProject _ self. Display newDepthNoRestore: displayDepth. ChangeSet newChanges: changeSet. TranscriptStream newTranscript: transcript. World pauseEventRecorder. world isMorph ifTrue: ["Entering a Morphic project" World _ world. world install. world triggerOpeningScripts] ifFalse: ["Entering an MVC project" World _ nil. Smalltalk at: #ScheduledControllers put: world. ScheduledControllers restore]. UIProcess _ Processor activeProcess. ! ! !Project methodsFor: 'menu messages' stamp: 'yo 7/2/2004 19:46'! exit "Leave the current project and return to the project in which this one was created." self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated]. parentProject enter: false revert: false saveForRevert: false. ! ! !Project methodsFor: 'menu messages' stamp: 'ar 11/25/2004 15:36'! finalEnterActions "Perform the final actions necessary as the receiver project is entered" | navigator armsLengthCmd navType thingsToUnhibernate fixBlock | self projectParameters at: #projectsToBeDeleted ifPresent: [ :projectsToBeDeleted | self removeParameter: #projectsToBeDeleted. projectsToBeDeleted do: [ :each | Project deletingProject: each. each removeChangeSetIfPossible]]. thingsToUnhibernate _ world valueOfProperty: #thingsToUnhibernate ifAbsent: [#()]. (thingsToUnhibernate anySatisfy:[:each| each isMorph and:[each hasProperty: #needsLayoutFixed]]) ifTrue:[fixBlock := self displayFontProgress]. thingsToUnhibernate do: [:each | each unhibernate]. world removeProperty: #thingsToUnhibernate. fixBlock ifNotNil:[ fixBlock value. world fullRepaintNeeded. ]. navType _ ProjectNavigationMorph preferredNavigator. armsLengthCmd _ self parameterAt: #armsLengthCmd ifAbsent: [nil]. navigator _ world findA: navType. (Preferences classicNavigatorEnabled and: [Preferences showProjectNavigator and: [navigator isNil]]) ifTrue: [(navigator _ navType new) bottomLeft: world bottomLeft; openInWorld: world]. navigator notNil & armsLengthCmd notNil ifTrue: [navigator color: Color lightBlue]. armsLengthCmd notNil ifTrue: [Preferences showFlapsWhenPublishing ifFalse: [self flapsSuppressed: true. navigator ifNotNil: [navigator visible: false]]. armsLengthCmd openInWorld: world]. Smalltalk isMorphic ifTrue: [world reformulateUpdatingMenus. world presenter positionStandardPlayer]. WorldState addDeferredUIMessage: [self startResourceLoading].! ! !Project methodsFor: 'menu messages' stamp: 'RAA 2/6/2001 14:21'! finalExitActions | navigator | world isMorph ifTrue: [ navigator _ world findA: ProjectNavigationMorph. navigator ifNotNil: [navigator retractIfAppropriate]. ]. ! ! !Project methodsFor: 'menu messages' stamp: 'sw 4/19/2001 12:58'! installProjectPreferences "Install the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" | localValue | Preferences allPreferenceObjects do: [:aPreference | aPreference localToProject ifTrue: [localValue _ self projectPreferenceFlagDictionary at: aPreference name ifAbsent: [nil]. localValue ifNotNil: [aPreference rawValue: localValue]]]! ! !Project methodsFor: 'menu messages' stamp: 'RAA 5/10/2001 16:59'! makeThumbnail "Make a thumbnail image of this project from the Display." world isMorph ifTrue: [world displayWorldSafely]. "clean pending damage" viewSize ifNil: [viewSize _ Display extent // 8]. thumbnail _ Form extent: viewSize depth: Display depth. (WarpBlt current toForm: thumbnail) sourceForm: Display; cellSize: 2; "installs a colormap" combinationRule: Form over; copyQuad: (Display boundingBox) innerCorners toRect: (0@0 extent: viewSize). InternalThreadNavigationMorph cacheThumbnailFor: self. ^thumbnail ! ! !Project methodsFor: 'menu messages' stamp: 'dgd 8/31/2003 19:37'! navigatorFlapVisible "Answer whether a Navigator flap is visible" ^ (Flaps sharedFlapsAllowed and: [self flapsSuppressed not]) and: [self isFlapIDEnabled: 'Navigator' translated]! ! !Project methodsFor: 'menu messages' stamp: 'sw 4/12/2001 22:29'! saveProjectPreferences "Preserve the settings of all preferences presently held individually by projects in the receiver's projectPreferenceFlagDictionary" Preferences allPreferenceObjects do: [:aPreference | aPreference localToProject ifTrue: [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]! ! !Project methodsFor: 'menu messages' stamp: 'sd 5/23/2003 14:40'! saveState "Save the current state in me prior to leaving this project" changeSet _ ChangeSet current. thumbnail ifNotNil: [thumbnail hibernate]. Smalltalk isMorphic ifTrue: [world _ World. world sleep. ActiveWorld _ ActiveHand _ ActiveEvent _ nil] ifFalse: [world _ ScheduledControllers. ScheduledControllers unCacheWindows]. Sensor flushAllButDandDEvents. "Will be reinstalled by World>>install" transcript _ Transcript. ! ! !Project methodsFor: 'menu messages' stamp: 'RAA 5/16/2001 18:00'! validateProjectNameIfOK: aBlock | details | details _ world valueOfProperty: #ProjectDetails. details ifNotNil: ["ensure project info matches real project name" details at: 'projectname' put: self name. ]. self doWeWantToRename ifFalse: [^aBlock value]. EToyProjectDetailsMorph getFullInfoFor: self ifValid: [ World displayWorldSafely. aBlock value. ] fixTemps expandedFormat: false ! ! !Project methodsFor: 'menu messages' stamp: 'gm 2/16/2003 20:37'! viewLocFor: exitedProject "Look for a view of the exitedProject, and return its center" | ctlr | world isMorph ifTrue: [world submorphsDo: [:v | ((v isSystemWindow) and: [v model == exitedProject]) ifTrue: [^v center]]] ifFalse: [ctlr := world controllerWhoseModelSatisfies: [:p | p == exitedProject]. ctlr ifNotNil: [^ctlr view windowBox center]]. ^Sensor cursorPoint "default result"! ! !Project methodsFor: 'release' stamp: 'RAA 5/10/2001 12:58'! deletingProject: aProject "Clear my previousProject link if it points at the given Project, which is being deleted." self flag: #bob. "zapping projects" parentProject == aProject ifTrue: [ parentProject _ parentProject parent ]. previousProject == aProject ifTrue: [previousProject _ nil]. nextProject == aProject ifTrue: [nextProject _ nil] ! ! !Project methodsFor: 'release' stamp: 'dgd 9/21/2003 17:49'! okToChange "Answer whether the window in which the project is housed can be dismissed -- which is destructive. We never clobber a project without confirmation" | ok is list | self subProjects size >0 ifTrue: [self inform: ('The project {1} contains sub-projects. You must remove these explicitly before removing their parent.' translated format:{self name}). ^ false]. ok _ world isMorph not and: [world scheduledControllers size <= 1]. ok ifFalse: [self isMorphic ifTrue: [self parent == CurrentProject ifFalse: [^ true]]]. "view from elsewhere. just delete it." ok _ (self confirm: ('Really delete the project {1} and all its windows?' translated format:{self name})). ok ifFalse: [^ false]. world isMorph ifTrue: [Smalltalk at: #WonderlandCameraMorph ifPresent:[:aClass | world submorphs do: "special release for wonderlands" [:m | (m isKindOf: aClass) and: [m getWonderland release]]]. "Remove Player classes and metaclasses owned by project" is _ ImageSegment new arrayOfRoots: (Array with: self). (list _ is rootsIncludingPlayers) ifNotNil: [list do: [:playerCls | (playerCls respondsTo: #isMeta) ifTrue: [playerCls isMeta ifFalse: [playerCls removeFromSystemUnlogged]]]]]. self removeChangeSetIfPossible. "do this last since it will render project inaccessible to #allProjects and their ilk" ProjectHistory forget: self. Project deletingProject: self. ^ true ! ! !Project methodsFor: 'release' stamp: 'RAA 5/10/2001 13:06'! removeChangeSetIfPossible | itsName | changeSet ifNil: [^self]. changeSet isEmpty ifFalse: [^self]. (changeSet projectsBelongedTo copyWithout: self) isEmpty ifFalse: [^self]. itsName _ changeSet name. ChangeSorter removeChangeSet: changeSet. "Transcript cr; show: 'project change set ', itsName, ' deleted.'" ! ! !Project methodsFor: 'release' stamp: 'gm 2/16/2003 20:37'! subProjects "Answer a list of all the subprojects of the receiver. This is nastily idiosyncratic." ^self isMorphic ifTrue: [world submorphs select: [:m | (m isSystemWindow) and: [m model isKindOf: Project]] thenCollect: [:m | m model]] ifFalse: [(world controllersSatisfying: [:m | m model isKindOf: Project]) collect: [:c | c model]]! ! !Project methodsFor: 'file in/out' stamp: 'RAA 5/10/2001 12:21'! armsLengthCommand: aCommand withDescription: aString | pvm tempProject foolingForm tempCanvas bbox crossHatchColor stride | "Set things up so that this aCommand is sent to self as a message after jumping to the parentProject. For things that can't be executed while in this project, such as saveAs, loadFromServer, storeOnServer. See ProjectViewMorph step." self isMorphic ifTrue: [ world borderWidth: 0. "get rid of the silly default border" tempProject _ Project newMorphic. foolingForm _ world imageForm. "make them think they never left" tempCanvas _ foolingForm getCanvas. bbox _ foolingForm boundingBox. crossHatchColor _ Color yellow alpha: 0.3. stride _ 20. 10 to: bbox width by: stride do: [ :x | tempCanvas fillRectangle: (x@0 extent: 1@bbox height) fillStyle: crossHatchColor. ]. 10 to: bbox height by: stride do: [ :y | tempCanvas fillRectangle: (0@y extent: bbox width@1) fillStyle: crossHatchColor. ]. tempProject world color: (InfiniteForm with: foolingForm). tempProject projectParameters at: #armsLengthCmd put: ( DoCommandOnceMorph new addText: aString; actionBlock: [ self doArmsLengthCommand: aCommand. ] fixTemps ). tempProject projectParameters at: #deleteWhenEnteringNewProject put: true. tempProject enter. ] ifFalse: [ parentProject ifNil: [^ self inform: 'The top project can''t do that']. pvm _ parentProject findProjectView: self. pvm armsLengthCommand: {self. aCommand}. self exit. ]. ! ! !Project methodsFor: 'file in/out' stamp: 'ar 5/30/2001 23:34'! compressFilesIn: tempDir to: localName in: localDirectory resources: collector "Compress all the files in tempDir making up a zip file in localDirectory named localName" | archive entry urlMap archiveName | urlMap _ Dictionary new. collector locatorsDo:[:loc| "map local file names to urls" urlMap at: (tempDir localNameFor: loc localFileName) put: loc urlString. ResourceManager cacheResource: loc urlString inArchive: localName]. archive _ ZipArchive new. tempDir fileNames do:[:fn| archiveName _ urlMap at: fn ifAbsent:[fn]. entry _ archive addFile: (tempDir fullNameFor: fn) as: archiveName. entry desiredCompressionMethod: ZipArchive compressionStored. ]. archive writeToFileNamed: (localDirectory fullNameFor: localName). archive close. tempDir fileNames do:[:fn| tempDir deleteFileNamed: fn ifAbsent:[]]. localDirectory deleteDirectory: tempDir localName.! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:50'! downloadUrl "^(self primaryServerIfNil: [^'']) downloadUrl" ^lastDirectory ifNil: [(self primaryServerIfNil: [^'']) downloadUrl] ifNotNil: [lastDirectory downloadUrl]! ! !Project methodsFor: 'file in/out' stamp: 'dgd 9/21/2003 17:41'! exportSegmentFileName: aFileName directory: aDirectory | exportChangeSet | "An experimental version to fileout a changeSet first so that a project can contain its own classes" "Store my project out on the disk as an *exported* ImageSegment. Put all outPointers in a form that can be resolved in the target image. Name it <project name>.extSeg. Player classes are included automatically." exportChangeSet _ nil. (changeSet notNil and: [changeSet isEmpty not]) ifTrue: [ (self confirm: 'Would you like to include all the changes in the change set as part of this publishing operation?' translated) ifTrue: [ exportChangeSet _ changeSet ]. ]. ^ self exportSegmentWithChangeSet: exportChangeSet fileName: aFileName directory: aDirectory ! ! !Project methodsFor: 'file in/out' stamp: 'yo 2/13/2005 18:54'! exportSegmentWithChangeSet: aChangeSetOrNil fileName: aFileName directory: aDirectory "Store my project out on the disk as an *exported* ImageSegment. All outPointers will be in a form that can be resolved in the target image. Name it <project name>.extSeg. Whatdo we do about subProjects, especially if they are out as local image segments? Force them to come in? Player classes are included automatically." | is str ans revertSeg roots holder collector fd mgr stacks | "Files out a changeSet first, so that a project can contain its own classes" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ false]. "Only Morphic projects for now" world ifNil: [^ false]. world presenter ifNil: [^ false]. Utilities emptyScrapsBook. world currentHand pasteBuffer: nil. "don't write the paste buffer." world currentHand mouseOverHandler initialize. "forget about any references here" "Display checkCurrentHandForObjectToPaste." Command initialize. world clearCommandHistory. world fullReleaseCachedState; releaseViewers. world cleanseStepList. world localFlapTabs size = world flapTabs size ifFalse: [ self error: 'Still holding onto Global flaps']. world releaseSqueakPages. ScriptEditorMorph writingUniversalTiles: (self projectParameterAt: #universalTiles ifAbsent: [false]). holder _ Project allProjects. "force them in to outPointers, where DiskProxys are made" "Just export me, not my previous version" revertSeg _ self projectParameters at: #revertToMe ifAbsent: [nil]. self projectParameters removeKey: #revertToMe ifAbsent: []. roots _ OrderedCollection new. roots add: self; add: world; add: transcript; add: changeSet; add: thumbnail. roots add: world activeHand. "; addAll: classList; addAll: (classList collect: [:cls | cls class])" roots _ roots reject: [ :x | x isNil]. "early saves may not have active hand or thumbnail" fd _ aDirectory directoryNamed: self resourceDirectoryName. fd assureExistence. "Clean up resource references before writing out" mgr _ self resourceManager. self resourceManager: nil. ResourceCollector current: ResourceCollector new. ResourceCollector current localDirectory: fd. ResourceCollector current baseUrl: self resourceUrl. ResourceCollector current initializeFrom: mgr. ProgressNotification signal: '2:findingResources' extra: '(collecting resources...)' translated. "Must activate old world because this is run at #armsLength. Otherwise references to ActiveWorld, ActiveHand, or ActiveEvent will not be captured correctly if referenced from blocks or user code." world becomeActiveDuring:[ is _ ImageSegment new copySmartRootsExport: roots asArray. "old way was (is _ ImageSegment new copyFromRootsForExport: roots asArray)" ]. self resourceManager: mgr. collector _ ResourceCollector current. ResourceCollector current: nil. ProgressNotification signal: '2:foundResources' extra: ''. is state = #tooBig ifTrue: [ collector replaceAll. ^ false]. str _ ''. "considered legal to save a project that has never been entered" (is outPointers includes: world) ifTrue: [ str _ str, '\Project''s own world is not in the segment.' translated withCRs]. str isEmpty ifFalse: [ ans _ (PopUpMenu labels: 'Do not write file Write file anyway Debug' translated) startUpWithCaption: str. ans = 1 ifTrue: [ revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. collector replaceAll. ^ false]. ans = 3 ifTrue: [ collector replaceAll. self halt: 'Segment not written' translated]]. stacks _ is findStacks. is writeForExportWithSources: aFileName inDirectory: fd changeSet: aChangeSetOrNil. SecurityManager default signFile: aFileName directory: fd. "Compress all files and update check sums" collector forgetObsolete. self storeResourceList: collector in: fd. self storeHtmlPageIn: fd. self writeStackText: stacks in: fd registerIn: collector. "local proj.005.myStack.t" self compressFilesIn: fd to: aFileName in: aDirectory resources: collector. "also deletes the resource directory" "Now update everything that we know about" mgr updateResourcesFrom: collector. revertSeg ifNotNil: [projectParameters at: #revertToMe put: revertSeg]. holder. collector replaceAll. world flapTabs do: [:ft | (ft respondsTo: #unhibernate) ifTrue: [ft unhibernate]]. is arrayOfRoots do: [:obj | obj class == ScriptEditorMorph ifTrue: [obj unhibernate]]. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:41'! fromMyServerLoad: otherProjectName | pair pr dirToUse | "If a newer version of me is on the server, load it." (pr _ Project named: otherProjectName) ifNotNil: ["it appeared" ^ pr enter ]. dirToUse _ self primaryServerIfNil: [ lastDirectory ifNil: [ self inform: 'Current project does not know a server either.'. ^nil]. lastDirectory]. pair _ self class mostRecent: otherProjectName onServer: dirToUse. pair first ifNil: [^self decideAboutCreatingBlank: otherProjectName]. "nothing to load" ^ProjectLoading installRemoteNamed: pair first from: dirToUse named: otherProjectName in: self ! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/15/2001 22:42'! htmlPagePrototype "Return the HTML page prototype" ^'<html> <head> <title>Squeak Project '! ! !Project methodsFor: 'file in/out' stamp: 'yo 2/17/2005 15:05'! loadFromServer: newerAutomatically "If a newer version of me is on the server, load it." | pair resp server | self assureIntegerVersion. self isCurrentProject ifTrue: ["exit, then do the command" ^ self armsLengthCommand: #loadFromServer withDescription: 'Loading' translated ]. server _ self tryToFindAServerWithMe ifNil: [^ nil]. pair _ self class mostRecent: self name onServer: server. pair first ifNil: [^ self inform: ('can''t find file on server for {1}' translated format: {self name})]. self currentVersionNumber > pair second ifTrue: [ ^ self inform: ('That server has an older version of the project.' translated)]. version = (Project parseProjectFileName: pair first) second ifTrue: [ resp _ (PopUpMenu labels: 'Reload anyway\Cancel' translated withCRs) startUpWithCaption: 'The only changes are the ones you made here.' translated. resp ~= 1 ifTrue: [^ nil] ] ifFalse: [ newerAutomatically ifFalse: [ resp _ (PopUpMenu labels: 'Load it\Cancel' translated withCRs) startUpWithCaption: 'A newer version exists on the server.' translated. resp ~= 1 ifTrue: [^ nil] ]. ]. "let's avoid renaming the loaded change set since it will be replacing ours" self projectParameters at: #loadingNewerVersion put: true. ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ ProjectLoading installRemoteNamed: pair first from: server named: self name in: parentProject ] ! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'! primaryServer "Return my primary server, that is the one I was downloaded from or are about to be stored on." ^self primaryServerIfNil: [nil]! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/7/2001 14:39'! primaryServerIfNil: aBlock "Return my primary server, that is the one I was downloaded from or are about to be stored on. If none is set execute the exception block" | serverList | serverList _ self serverList. ^serverList isEmptyOrNil ifTrue: [aBlock value] ifFalse: [serverList first]! ! !Project methodsFor: 'file in/out' stamp: 'ar 2/27/2001 13:44'! projectExtension ^self class projectExtension! ! !Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 19:50'! saveForRevert "Exit to the parent project. Do a GC. Save the project in a segment. Record the ImageSegment object as the revertToMe in Project parameters" self isTopProject ifTrue: [^ self inform: 'Can''t exit the top project' translated]. parentProject enter: false revert: false saveForRevert: true. "does not return!!" ! ! !Project methodsFor: 'file in/out' stamp: 'mir 8/10/2001 17:49'! serverList | servers server | "Take my list of server URLs and return a list of ServerDirectories to write on." urlList isEmptyOrNil ifTrue: [^ nil]. servers _ OrderedCollection new. urlList do: [:url | server _ ServerDirectory serverForURL: url. server ifNotNil: [servers add: server]. server _ ServerDirectory serverForURL: url asUrl downloadUrl. server ifNotNil: [servers add: server]]. ^servers isEmpty ifTrue: [nil] ifFalse: [servers]! ! !Project methodsFor: 'file in/out' stamp: 'RAA 2/19/2001 07:37'! squeakletDirectory ^self class squeakletDirectory! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/15/2001 22:53'! storeHtmlPageIn: aFileDirectory "Prepare the HTML wrapper for the current project" | file page | file _ aFileDirectory forceNewFileNamed: (self name, FileDirectory dot,'html'). page _ self htmlPagePrototype. page _ page copyReplaceAll: '$$PROJECT$$' with: self versionedFileName. page _ page copyReplaceAll: '$$WIDTH$$' with: world bounds width printString. page _ page copyReplaceAll: '$$HEIGHT$$' with: world bounds height printString. page _ page copyReplaceAll: String cr with: String lf. "not sure if necessary..." file nextPutAll: page. file close.! ! !Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'! storeOnServer "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." world setProperty: #optimumExtentFromAuthor toValue: world extent. self validateProjectNameIfOK: [ self isCurrentProject ifTrue: ["exit, then do the command" ^ self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfo. ].! ! !Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'! storeOnServerAssumingNameValid "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." world setProperty: #optimumExtentFromAuthor toValue: world extent. self isCurrentProject ifTrue: ["exit, then do the command" ^ self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfo. ! ! !Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 19:59'! storeOnServerInnards "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." | resp newName primaryServerDirectory serverVersionPair localDirectory localVersionPair myVersionNumber warning maxNumber suppliedPassword oldResourceUrl | self assureIntegerVersion. "Find out what version" primaryServerDirectory _ self primaryServerIfNil: [ (primaryServerDirectory _ self findAFolderToStoreProjectIn) ifNil: [^self]. oldResourceUrl _ self resourceUrl. primaryServerDirectory == #localOnly ifTrue: [ self storeNewPrimaryURL: FileDirectory default url. nil ] ifFalse: [ self storeNewPrimaryURL: primaryServerDirectory downloadUrl. primaryServerDirectory ]. ]. localDirectory _ self squeakletDirectory. serverVersionPair _ self class mostRecent: self name onServer: primaryServerDirectory. localVersionPair _ self class mostRecent: self name onServer: localDirectory. maxNumber _ myVersionNumber _ self currentVersionNumber. ProgressNotification signal: '2:versionsDetected'. warning _ ''. myVersionNumber < serverVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) on the server' translated. maxNumber _ maxNumber max: serverVersionPair second. ]. myVersionNumber < localVersionPair second ifTrue: [ warning _ warning,'\There are newer version(s) in the local directory' translated. maxNumber _ maxNumber max: localVersionPair second. ]. "8 Nov 2000 - only check on the first attempt to publish" myVersionNumber = 0 ifTrue: [ warning isEmpty ifFalse: [ myVersionNumber = 0 ifTrue: [ warning _ warning,'\THIS PROJECT HAS NEVER BEEN SAVED' translated. ]. warning _ 'WARNING' translated, '\Project: ' translated, self name,warning. resp _ (PopUpMenu labels: 'Store anyway\Cancel' translated withCRs) startUpWithCaption: (warning, '\Please cancel, rename this project, and see what is there.' translated) withCRs. resp ~= 1 ifTrue: [^ nil] ]. ]. version _ self bumpVersion: maxNumber. oldResourceUrl ifNotNil: [self resourceManager adjustToNewServer: self resourceUrl from: oldResourceUrl]. "write locally - now zipped automatically" newName _ self versionedFileName. lastSavedAtSeconds _ Time totalSeconds. self exportSegmentFileName: newName directory: localDirectory. (localDirectory readOnlyFileNamed: newName) setFileTypeToObject; close. ProgressNotification signal: '4:localSaveComplete'. "3 is deep in export logic" primaryServerDirectory ifNotNil: [ suppliedPassword _ ''. Preferences passwordsOnPublish ifTrue: [ suppliedPassword _ FillInTheBlank requestPassword: 'Project password' translated ]. [ primaryServerDirectory writeProject: self inFileNamed: newName asFileName fromDirectory: localDirectory. ] on: ProjectPasswordNotification do: [ :ex | ex resume: (suppliedPassword ifNil: ['']) ]. ]. ProgressNotification signal: '9999 save complete'. "Later, store with same name on secondary servers. Still can be race conditions. All machines will go through the server list in the same order." "2 to: servers size do: [:aServer | aServer putFile: local named: newName]." ! ! !Project methodsFor: 'file in/out' stamp: 'yo 7/2/2004 17:45'! storeOnServerShowProgressOn: aMorphOrNil forgetURL: forget "Save to disk as an Export Segment. Then put that file on the server I came from, as a new version. Version is literal piece of file name. Mime encoded and http encoded." world setProperty: #optimumExtentFromAuthor toValue: world extent. self validateProjectNameIfOK: [ self isCurrentProject ifTrue: ["exit, then do the command" forget ifTrue: [self forgetExistingURL] ifFalse: [urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy]]. ^self armsLengthCommand: #storeOnServerAssumingNameValid withDescription: 'Publishing' translated ]. self storeOnServerWithProgressInfoOn: aMorphOrNil. ] fixTemps. ! ! !Project methodsFor: 'file in/out' stamp: 'ar 3/17/2001 23:57'! storeSegment "Store my project out on the disk as an ImageSegment. Keep the outPointers in memory. Name it .seg. *** Caller must be holding (Project alInstances) to keep subprojects from going out. ***" | is sizeHint | (World == world) ifTrue: [^ false]. "self inform: 'Can''t send the current world out'." world isInMemory ifFalse: [^ false]. "already done" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ false]. "Only Morphic projects for now" world ifNil: [^ false]. world presenter ifNil: [^ false]. Utilities emptyScrapsBook. World checkCurrentHandForObjectToPaste. world releaseSqueakPages. sizeHint _ self projectParameters at: #segmentSize ifAbsent: [0]. is _ ImageSegment new copyFromRootsLocalFileFor: (Array with: world presenter with: world) "world, and all Players" sizeHint: sizeHint. is state = #tooBig ifTrue: [^ false]. is segment size < 2000 ifTrue: ["debugging" Transcript show: self name, ' only ', is segment size printString, 'bytes in Segment.'; cr]. self projectParameters at: #segmentSize put: is segment size. is extract; writeToFile: self name. ^ true ! ! !Project methodsFor: 'file in/out' stamp: 'md 10/22/2003 16:27'! storeSegmentNoFile "For testing. Make an ImageSegment. Keep the outPointers in memory. Also useful if you want to enumerate the objects in the segment afterwards (allObjectsDo:)" | is str | (World == world) ifTrue: [^ self]. " inform: 'Can''t send the current world out'." world isInMemory ifFalse: [^ self]. "already done" world isMorph ifFalse: [ self projectParameters at: #isMVC put: true. ^ self]. "Only Morphic projects for now" world ifNil: [^ self]. world presenter ifNil: [^ self]. "Do this on project enter" World flapTabs do: [:ft | ft referent adaptToWorld: World]. "Hack to keep the Menu flap from pointing at my project" "Preferences setPreference: #useGlobalFlaps toValue: false." "Utilities globalFlapTabsIfAny do: [:aFlapTab | Utilities removeFlapTab: aFlapTab keepInList: false]. Utilities clobberFlapTabList. " "project world deleteAllFlapArtifacts." "self currentWorld deleteAllFlapArtifacts. " Utilities emptyScrapsBook. World checkCurrentHandForObjectToPaste2. is _ ImageSegment new copyFromRootsLocalFileFor: (Array with: world presenter with: world) "world, and all Players" sizeHint: 0. is segment size < 800 ifTrue: ["debugging" Transcript show: self name, ' did not get enough objects'; cr. ^ Beeper beep]. false ifTrue: [ str _ String streamContents: [:strm | strm nextPutAll: 'Only a tiny part of the project got into the segment'. strm nextPutAll: '\These are pointed to from the outside:' withCRs. is outPointers do: [:out | (out class == Presenter) | (out class == ScriptEditorMorph) ifTrue: [ strm cr. out printOn: strm. self systemNavigation browseAllObjectReferencesTo: out except: (Array with: is outPointers) ifNone: [:obj | ]]. (is arrayOfRoots includes: out class) ifTrue: [strm cr. out printOn: strm. self systemNavigation browseAllObjectReferencesTo: out except: (Array with: is outPointers) ifNone: [:obj | ]]]]. self inform: str. ^ is inspect]. is extract. "is instVarAt: 2 put: is segment clone." "different memory" ! ! !Project methodsFor: 'file in/out' stamp: 'nk 7/30/2004 17:52'! storeSomeSegment "Try all projects to see if any is ready to go out. Send at most three of them. Previous one has to wait for a garbage collection before it can go out." | cnt pList start proj gain | cnt := 0. gain := 0. pList := Project allProjects. start := pList size atRandom. "start in a random place" start to: pList size + start do: [:ii | proj := pList atWrap: ii. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain := gain + (proj projectParameters at: #segmentSize ifAbsent: [0]). "a guess" Beeper beep. (cnt := cnt + 1) >= 2 ifTrue: [^gain]]]. Beeper beep. ^gain! ! !Project methodsFor: 'file in/out' stamp: 'md 10/22/2003 17:54'! storeToMakeRoom "Write out enough projects to fulfill the space goals. Include the size of the project about to come in." | params memoryEnd goalFree cnt gain proj skip tried | GoalFreePercent ifNil: [GoalFreePercent _ 33]. GoalNotMoreThan ifNil: [GoalNotMoreThan _ 20000000]. params _ SmalltalkImage current getVMParameters. memoryEnd _ params at: 3. " youngSpaceEnd _ params at: 2. free _ memoryEnd - youngSpaceEnd. " goalFree _ GoalFreePercent asFloat / 100.0 * memoryEnd. goalFree _ goalFree min: GoalNotMoreThan. world isInMemory ifFalse: ["enough room to bring it in" goalFree _ goalFree + (self projectParameters at: #segmentSize ifAbsent: [0])]. cnt _ 30. gain _ Smalltalk garbageCollectMost. "skip a random number of projects that are in memory" proj _ self. skip _ 6 atRandom. [proj _ proj nextInstance ifNil: [Project someInstance]. proj world isInMemory ifTrue: [skip _ skip - 1]. skip > 0] whileTrue. cnt _ 0. tried _ 0. [gain > goalFree] whileFalse: [ proj _ proj nextInstance ifNil: [Project someInstance]. proj storeSegment ifTrue: ["Yes, did send its morphs to the disk" gain _ gain + (proj projectParameters at: #segmentSize ifAbsent: [20000]). "a guess" Beeper beep. (cnt _ cnt + 1) > 5 ifTrue: [^ self]]. "put out 5 at most" (tried _ tried + 1) > 23 ifTrue: [^ self]]. "don't get stuck in a loop"! ! !Project methodsFor: 'file in/out' stamp: 'yo 2/17/2005 15:10'! tryToFindAServerWithMe | resp primaryServerDirectory | urlList isEmptyOrNil ifTrue: [urlList _ parentProject urlList copy]. [self primaryServer isNil] whileTrue: [ resp _ (PopUpMenu labels: 'Try to find a server\Cancel' translated withCRs) startUpWithCaption: 'This project thinks it has never been on a server' translated. resp ~= 1 ifTrue: [^ nil]. (primaryServerDirectory _ self findAFolderToLoadProjectFrom) ifNil: [^nil]. self storeNewPrimaryURL: primaryServerDirectory downloadUrl. ]. ^self primaryServer ! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/25/2001 10:55'! url | firstURL | "compose my url on the server" urlList isEmptyOrNil ifTrue: [^'']. firstURL _ urlList first. firstURL isEmpty ifFalse: [ firstURL last == $/ ifFalse: [firstURL _ firstURL, '/']]. ^ firstURL, self versionedFileName ! ! !Project methodsFor: 'file in/out' stamp: 'mir 8/8/2001 17:58'! urlForLoading "compose a url that will load me in someone's browser" | myServer serverList myUrl downloadUrl | serverList _ self serverList. serverList isEmptyOrNil ifTrue: [ urlList isEmptyOrNil ifTrue: [^nil]. downloadUrl _ urlList first asUrl downloadUrl] ifFalse: [ myServer _ serverList first. myUrl _ myServer altUrl. myUrl last == $/ ifFalse: [myUrl _ myUrl , '/']. downloadUrl _ myUrl]. ^downloadUrl , (self name, FileDirectory dot,'html') encodeForHTTP ! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:45'! versionForFileName "Project current versionForFileName" ^self class versionForFileName: self currentVersionNumber! ! !Project methodsFor: 'file in/out' stamp: 'mir 6/21/2001 15:43'! versionedFileName "Project current versionedFileName" ^String streamContents:[:s| s nextPutAll: self name. s nextPutAll: FileDirectory dot. s nextPutAll: self versionForFileName. s nextPutAll: FileDirectory dot. s nextPutAll: self projectExtension. ] ! ! !Project methodsFor: 'file in/out' stamp: 'yo 3/25/2004 23:32'! writeFileNamed: localFileName fromDirectory: localDirectory toServer: primaryServerDirectory | local resp gifFileName f | local _ localDirectory oldFileNamed: localFileName. resp _ primaryServerDirectory upLoadProject: local named: localFileName resourceUrl: self resourceUrl retry: false. local close. resp == true ifFalse: [ "abandon resources that would've been stored with the project" self resourceManager abandonResourcesThat: [:loc| loc urlString beginsWith: self resourceUrl]. self inform: 'the primary server of this project seems to be down (', resp printString,')'. ^ self ]. gifFileName _ self name,'.gif'. localDirectory deleteFileNamed: gifFileName ifAbsent: []. local _ localDirectory fileNamed: gifFileName. thumbnail ifNil: [ (thumbnail _ Form extent: 100@80) fillColor: Color orange ] ifNotNil: [ thumbnail unhibernate. ]. f _ thumbnail colorReduced. "minimize depth" f depth > 8 ifTrue: [ f _ thumbnail asFormOfDepth: 8 ]. GIFReadWriter putForm: f onStream: local. local close. [local _ StandardFileStream readOnlyFileNamed: (localDirectory fullNameFor: gifFileName). (primaryServerDirectory isKindOf: FileDirectory) ifTrue: [primaryServerDirectory deleteFileNamed: gifFileName ifAbsent: []]. resp _ primaryServerDirectory putFile: local named: gifFileName retry: false. ] on: Error do: [:ex |]. local close. primaryServerDirectory updateProjectInfoFor: self. primaryServerDirectory sleep. "if ftp, close the connection" ! ! !Project methodsFor: 'file in/out' stamp: 'tk 6/28/2001 16:16'! writeStackText: stacks in: resourceDirectory registerIn: aCollector "The user's text is very valuable. Write an extra file with just the text. It can be read in case the Project can't be opened." "Find allText for each stack, storeOn a local file in the resources folder, with a name like myProj.005.myStack.t. Make the names be unique." "get project name and version" | localName sn trial char ind fs resourceURL textLoc | resourceURL _ self resourceUrl. stacks do: [:stackObj | "Construct a good file name" localName _ self versionedFileName allButLast: 2. "projectName.005." stacks size = 1 ifFalse: ["must distinguish between stacks in the project" (sn _ stackObj knownName) ifNil: [ sn _ stackObj hash printString]. "easy name, or use hash" localName _ localName , sn, FileDirectory dot]. "projectName.005.myStack." localName _ localName , 't'. "See if in use because truncates same as another, fix last char, try again" [trial _ resourceDirectory checkName: localName fixErrors: true. trial endsWith: '.t'] whileFalse: [ localName _ (localName allButLast: 3) , FileDirectory dot, 't']. [resourceDirectory fileExists: trial] whileTrue: [ char _ trial at: (ind _ trial size - 3). trial at: ind put: (char asciiValue + 1) asCharacter]. "twiddle it a little" "write allText in file" fs _ resourceDirectory newFileNamed: trial. fs timeStamp; cr; nextPutAll: '''This is the text for a stack in this project. Use only in an emergency, if the project file is ever unreadable.''.'; cr; cr. stackObj getAllText storeOn: fs. fs close. textLoc _ (ResourceLocator new) localFileName: trial; urlString: resourceURL, '/', trial. aCollector locatorMap at: trial "any distinct object" put: textLoc. ].! ! !Project methodsFor: 'project parameters' stamp: 'sw 4/24/2001 11:58'! initializeProjectParameters "Initialize the project parameters." projectParameters _ IdentityDictionary new. ^ projectParameters! ! !Project methodsFor: 'project parameters' stamp: 'di 11/16/2001 21:08'! initializeProjectPreferences "Initialize the project's preferences from currently-prevailing preferences that are currently being held in projects in this system" projectPreferenceFlagDictionary _ Project current projectPreferenceFlagDictionary deepCopy. "Project overrides in the new project start out being the same set of overrides in the calling project" Preferences allPreferenceObjects do: "in case we missed some" [:aPreference | aPreference localToProject ifTrue: [(projectPreferenceFlagDictionary includesKey: aPreference name) ifFalse: [projectPreferenceFlagDictionary at: aPreference name put: aPreference preferenceValue]]]. self isMorphic ifFalse: [self flapsSuppressed: true]. (Project current projectParameterAt: #disabledGlobalFlapIDs ifAbsent: [nil]) ifNotNilDo: [:idList | self projectParameterAt: #disabledGlobalFlapIDs put: idList copy] ! ! !Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:35'! noteThatParameter: prefSymbol justChangedTo: aBoolean "Provides a hook so that a user's toggling of a project parameter might precipitate some immediate action" ! ! !Project methodsFor: 'project parameters' stamp: 'sw 2/15/2001 14:32'! projectParameterAt: aSymbol ifAbsent: aBlock "Answer the project parameter stored at the given symbol, or the result of evaluating the block" ^ self projectParameters at: aSymbol ifAbsent: [aBlock value]! ! !Project methodsFor: 'project parameters' stamp: 'sw 9/28/2001 08:49'! projectParameterAt: aKey ifAbsentPut: defaultValueBlock "Return the project parameter setting at the given key. If there is no entry for this key in the Parameters dictionary, create one with the value of defaultValueBlock as its value" ^ self projectParameters at: aKey ifAbsentPut: defaultValueBlock! ! !Project methodsFor: 'project parameters' stamp: 'sw 2/17/2001 21:36'! projectParameterAt: aSymbol put: aValue "Set the given project parameter to the given value" self projectParameters at: aSymbol put: aValue. self noteThatParameter: aSymbol justChangedTo: aValue. ^ aValue! ! !Project methodsFor: 'project parameters' stamp: 'sw 4/12/2001 23:36'! projectPreferenceAt: aSymbol "Answer the project preference stored at the given symbol. If there is none in the local preference dictionary, it must be because it was only latterly declared to be a project-local preference, so obtain its initial value instead from the last-known global or default setting" | aValue | ^ self projectPreferenceAt: aSymbol ifAbsent: [aValue _ Preferences valueOfFlag: aSymbol. self projectPreferenceFlagDictionary at: aSymbol put: aValue. ^ aValue]! ! !Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:25'! projectPreferenceAt: aSymbol ifAbsent: aBlock "Answer the project preference stored at the given symbol, or the result of evaluating the block" ^ self projectPreferenceFlagDictionary at: aSymbol ifAbsent: [aBlock value]! ! !Project methodsFor: 'project parameters' stamp: 'sw 2/16/2001 22:23'! projectPreferenceFlagDictionary "Answer the dictionary that holds the project preferences, creating it if necessary" ^ projectPreferenceFlagDictionary ifNil: [projectPreferenceFlagDictionary _ IdentityDictionary new]! ! !Project methodsFor: 'flaps support' stamp: 'dgd 8/31/2003 19:42'! assureFlapIntegrity "Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them. Also, old (and damaging) parameters that held references to actual disabled flaps are cleansed" | disabledFlapIDs currentGlobalIDs oldList | Smalltalk isMorphic ifTrue: [disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new]. currentGlobalIDs _ Flaps globalFlapTabsIfAny collect: [:f | f flapID]. oldList _ Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil]. oldList ifNotNil: [disabledFlapIDs _ oldList collect: [:aFlap | aFlap flapID]. disabledFlapIDs addAll: {'Scripting' translated. 'Stack Tools' translated. 'Painting' translated}]. disabledFlapIDs _ disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID]. self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs asSet. self assureNavigatorPresenceMatchesPreference]. projectParameters ifNotNil: [projectParameters removeKey: #disabledGlobalFlaps ifAbsent: []]! ! !Project methodsFor: 'flaps support' stamp: 'sw 5/7/2001 12:48'! cleanseDisabledGlobalFlapIDsList "Make certain that the items on the disabled-global-flap list are actually global flaps, and if not, get rid of them" | disabledFlapIDs currentGlobalIDs oldList | Smalltalk isMorphic ifTrue: [disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [Set new]. currentGlobalIDs _ Flaps globalFlapTabsIfAny collect: [:f | f flapID]. oldList _ Project current projectParameterAt: #disabledGlobalFlaps ifAbsent: [nil]. oldList ifNotNil: [disabledFlapIDs _ oldList select: [:aFlap | aFlap flapID]]. disabledFlapIDs _ disabledFlapIDs select: [:anID | currentGlobalIDs includes: anID]. self projectParameterAt: #disabledGlobalFlapIDs put: disabledFlapIDs]. projectParameters ifNotNil: [projectParameters removeKey: #disabledGlobalFlaps ifAbsent: []]. ! ! !Project methodsFor: 'flaps support' stamp: 'sw 4/29/2001 23:45'! enableDisableGlobalFlap: aFlapTab "For the benefit of pre-existing which-global-flap buttons from a design now left behind." self flag: #toRemove. ^ self inform: 'Sorry, this is an obsolete menu; please dismiss it and get a fresh menu. Thanks.'.! ! !Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:03'! flapsSuppressed "Answer whether flaps are suppressed in this project" ^ self showSharedFlaps not! ! !Project methodsFor: 'flaps support' stamp: 'di 11/18/2001 14:34'! flapsSuppressed: aBoolean "Make the setting of the flag that governs whether global flaps are suppressed in the project be as indicated and add or remove the actual flaps" self projectPreferenceFlagDictionary at: #showSharedFlaps put: aBoolean not. self == Project current "Typical case" ifTrue: [Preferences setPreference: #showSharedFlaps toValue: aBoolean not] ifFalse: "Anomalous case where this project is not the current one." [aBoolean ifTrue: [Flaps globalFlapTabsIfAny do: [:aFlapTab | Flaps removeFlapTab: aFlapTab keepInList: true]] ifFalse: [Smalltalk isMorphic ifTrue: [self currentWorld addGlobalFlaps]]]. Project current assureNavigatorPresenceMatchesPreference! ! !Project methodsFor: 'flaps support' stamp: 'sw 4/30/2001 20:42'! globalFlapWithIDEnabledString: aFlapID "Answer the string to be shown in a menu to represent the status of the given flap regarding whether it it should be shown in this project." | aFlapTab | aFlapTab _ Flaps globalFlapTabWithID: aFlapID. ^ (self isFlapEnabled: aFlapTab) ifTrue: ['', aFlapTab wording] ifFalse: ['', aFlapTab wording]! ! !Project methodsFor: 'flaps support' stamp: 'sw 5/5/2001 00:37'! isFlapEnabled: aFlapTab "Answer whether the given flap tab is enabled in this project" ^ self isFlapIDEnabled: aFlapTab flapID! ! !Project methodsFor: 'flaps support' stamp: 'sw 4/17/2001 12:49'! isFlapIDEnabled: aFlapID "Answer whether a flap of the given ID is enabled in this project" | disabledFlapIDs | disabledFlapIDs _ self parameterAt: #disabledGlobalFlapIDs ifAbsent: [^ true]. ^ (disabledFlapIDs includes: aFlapID) not! ! !Project methodsFor: 'flaps support' stamp: 'sw 4/24/2001 11:02'! showSharedFlaps "Answer whether shared flaps are shown or suppressed in this project" | result | result _ Preferences showSharedFlaps. ^ self == Project current ifTrue: [result] ifFalse: [self projectPreferenceAt: #showSharedFlaps ifAbsent: [result]]! ! !Project methodsFor: 'language' stamp: 'dgd 10/7/2004 21:05'! chooseNaturalLanguage "Put up a menu allowing the user to choose the natural language for the project" | aMenu availableLanguages | aMenu _ MenuMorph new defaultTarget: self. aMenu addTitle: 'choose language' translated. aMenu lastItem setBalloonText: 'This controls the human language in which tiles should be viewed. It is potentially extensible to be a true localization mechanism, but initially it only works in the classic tile scripting system. Each project has its own private language choice' translated. Preferences noviceMode ifFalse:[aMenu addStayUpItem]. availableLanguages := NaturalLanguageTranslator availableLanguageLocaleIDs asSortedCollection:[:x :y | x displayName < y displayName]. availableLanguages do: [:localeID | aMenu addUpdating: #stringForLanguageNameIs: target: Locale selector: #switchToID: argumentList: {localeID}]. aMenu popUpInWorld "Project current chooseNaturalLanguage"! ! !Project methodsFor: 'language' stamp: 'mir 7/21/2004 16:54'! localeChanged "Set the project's natural language as indicated" | | self localeID = LocaleID current ifTrue: [^self]. self projectParameterAt: #localeID put: LocaleID current. self updateLocaleDependents! ! !Project methodsFor: 'language' stamp: 'mir 7/15/2004 14:51'! localeID "Answer the natural language for the project" | prev | ^ self projectParameterAt: #localeID ifAbsentPut: [ (prev _ self previousProject) ifNotNil: [prev projectParameterAt: #localeID ifAbsent: [LocaleID default]] ifNil: [LocaleID default]]! ! !Project methodsFor: 'language' stamp: 'dgd 10/7/2004 20:51'! naturalLanguage "Answer the natural language for the project" ^ self localeID displayName! ! !Project methodsFor: 'language' stamp: 'nk 9/3/2004 13:00'! setFlaps | flapTabs flapIDs sharedFlapTabs navigationMorph | flapTabs _ ActiveWorld flapTabs. flapIDs _ flapTabs collect: [:tab | tab knownName]. flapTabs do: [:tab | (tab isMemberOf: ViewerFlapTab) ifFalse: [tab isGlobalFlap ifTrue: [Flaps removeFlapTab: tab keepInList: false. tab currentWorld reformulateUpdatingMenus] ifFalse: [| referent | referent _ tab referent. referent isInWorld ifTrue: [referent delete]. tab delete]]]. sharedFlapTabs _ Flaps classPool at: #SharedFlapTabs. flapIDs do: [:id | id = 'Navigator' translated ifTrue: [sharedFlapTabs add: Flaps newNavigatorFlap]. id = 'Widgets' translated ifTrue: [sharedFlapTabs add: Flaps newWidgetsFlap]. id = 'Tools' translated ifTrue: [sharedFlapTabs add: Flaps newToolsFlap]. id = 'Squeak' translated ifTrue: [sharedFlapTabs add: Flaps newSqueakFlap]. id = 'Supplies' translated ifTrue: [sharedFlapTabs add: Flaps newSuppliesFlap]. id = 'Stack Tools' translated ifTrue: [sharedFlapTabs add: Flaps newStackToolsFlap]. id = 'Painting' translated ifTrue: [sharedFlapTabs add: Flaps newPaintingFlap]. id = 'Objects' translated ifTrue: [sharedFlapTabs add: Flaps newObjectsFlap ]]. 2 timesRepeat: [flapIDs do: [:id | Flaps enableDisableGlobalFlapWithID: id]]. ActiveWorld flapTabs do: [:flapTab | flapTab isCurrentlyTextual ifTrue: [flapTab changeTabText: flapTab knownName]]. Flaps positionNavigatorAndOtherFlapsAccordingToPreference. navigationMorph _ World findDeeplyA: ProjectNavigationMorph preferredNavigator. navigationMorph isNil ifTrue: [^ self]. navigationMorph allMorphs do: [:morph | morph class == SimpleButtonDelayedMenuMorph ifTrue: [(morph findA: ImageMorph) isNil ifTrue: [| label | label _ morph label. label isNil ifFalse: [| name | name _ morph knownName. name isNil ifTrue: [morph name: label. name _ label]. morph label: name translated]]]]! ! !Project methodsFor: 'language' stamp: 'yo 8/11/2003 16:46'! setPaletteFor: aLanguageSymbol | prototype formKey form | prototype _ PaintBoxMorph prototype. formKey _ ('offPalette' , aLanguageSymbol) asSymbol. form _ Imports default imports at: formKey ifAbsent: [Imports default imports at: #offPaletteEnglish ifAbsent: []]. form isNil ifFalse: [prototype loadOffForm: form]. formKey _ ('pressedPalette' , aLanguageSymbol) asSymbol. form _ Imports default imports at: formKey ifAbsent: [Imports default imports at: #pressedPaletteEnglish ifAbsent: []]. form isNil ifFalse: [prototype loadPressedForm: form]. ! ! !Project methodsFor: 'language' stamp: 'mir 8/31/2004 15:32'! updateLocaleDependents "Set the project's natural language as indicated" ActiveWorld allTileScriptingElements do: [:viewerOrScriptor | viewerOrScriptor localeChanged]. Flaps disableGlobalFlaps: false. Preferences eToyFriendly ifTrue: [ Flaps addAndEnableEToyFlaps. ActiveWorld addGlobalFlaps] ifFalse: [Flaps enableGlobalFlaps]. (Project current isFlapIDEnabled: 'Navigator' translated) ifFalse: [Flaps enableDisableGlobalFlapWithID: 'Navigator' translated]. ParagraphEditor initializeTextEditorMenus. Utilities emptyScrapsBook. MenuIcons initializeTranslations. LanguageEnvironment localeChanged. #(PartsBin ParagraphEditor BitEditor FormEditor StandardSystemController) do: [ :key | Smalltalk at: key ifPresent: [ :class | class initialize ]]. "self setFlaps. self setPaletteFor: aLanguageSymbol." ! ! !Project methodsFor: 'SuperSwiki' stamp: 'yo 2/12/2005 19:25'! tellAFriend: emailAddressOrNil | urlForLoading | " Project current tellAFriend " (urlForLoading _ self urlForLoading) ifNil: [ urlForLoading _ self url "fallback for dtp servers" ]. urlForLoading isEmptyOrNil ifTrue: [ ^self inform: 'Since this project has not been saved yet, I cannot tell someone where it is.' translated ]. HTTPClient tellAFriend: emailAddressOrNil url: urlForLoading name: self name! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 17:25'! abortResourceLoading "Abort loading resources" resourceManager ifNil:[^self]. resourceManager stopDownload.! ! !Project methodsFor: 'resources' stamp: 'mir 6/21/2001 15:43'! resourceDirectoryName "Project current resourceDirectoryName" ^String streamContents:[:s| s nextPutAll: self name. s nextPutAll: FileDirectory dot. s nextPutAll: self versionForFileName. ] ! ! !Project methodsFor: 'resources' stamp: 'ar 2/27/2001 17:02'! resourceManager ^resourceManager ifNil:[resourceManager _ ResourceManager new]! ! !Project methodsFor: 'resources' stamp: 'ar 2/27/2001 15:49'! resourceManager: aResourceManager resourceManager _ aResourceManager! ! !Project methodsFor: 'resources' stamp: 'mir 6/26/2001 17:34'! resourceUrl "compose my base url for resources on the server" | firstURL | " primaryServer _ self primaryServerIfNil: [^'']. firstURL _ primaryServer altUrl ifNil: [primaryServer url]." firstURL _ self downloadUrl. firstURL isEmpty ifFalse: [firstURL last == $/ ifFalse: [firstURL _ firstURL, '/']]. ^ firstURL, self resourceDirectoryName , '/' ! ! !Project methodsFor: 'resources' stamp: 'mir 6/18/2001 16:19'! startResourceLoading "Abort loading resources" resourceManager ifNil:[^self]. resourceManager adjustToDownloadUrl: self resourceUrl. resourceManager startDownload! ! !Project methodsFor: 'resources' stamp: 'ar 3/2/2001 15:16'! storeResourceList: collector in: fd "Store a list of all used resources in the given directory. Used for maintenance." | file rcName | rcName _ self resourceDirectoryName,'.rc'. file _ fd forceNewFileNamed: rcName. collector locatorsDo:[:loc| file nextPutAll: loc urlString; cr]. file close. file _ fd readOnlyFileNamed: rcName. file compressFile. fd deleteFileNamed: rcName ifAbsent:[].! ! !Project methodsFor: 'active process' stamp: 'ar 10/12/2004 21:46'! depth "Return the depth of this project from the top. topProject = 0, next = 1, etc." "Project current depth." | depth project | depth _ 0. project _ self. [project isTopProject] whileFalse: [project _ project parent. depth _ depth + 1]. ^ depth! ! !Project commentStamp: 'tk 12/2/2004 12:38' prior: 0! A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet. A project knows who its parent project is. When you change projects, whether by entering or exiting, the screen state of the project being exited is saved in that project. A project is retained by its view in the parent world. It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project. As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds. The distinction is based on whether the variable 'world' contains a WorldMorph or a ControlManager. Saving and Loading Projects may be stored on the disk in external format. (Project named: 'xxx') exportSegment, or choose 'store project on file...'. Projects may be loaded from a server and stored back. Storing on a server never overwrites; it always makes a new version. A project remembers the url of where it lives in urlList. The list is length one, for now. The url may point to a local disk instead of a server. All projects that the user looks at, are cached in the Squeaklet folder. Sorted by server. The cache holds the most recent version only. When a project is loaded into Squeak, its objects are converted to the current version. There are three levels of conversion. First, each object is converted from raw bits to an object in its old format. Then it is sent some or all of these messages: comeFullyUpOnReload: smartRefStream Used to re-discover an object that already exists in this image, such as a resource, global variable, Character, or Symbol. (sent to objects in outPointers) convertToCurrentVersion: varDict refStream: smartRefStrm fill in fields that have been added to a class since the object was stored. Used to set the extra inst var to a default value. Or, return a new object of a different class. (sent to objects that changed instance variables) fixUponLoad: aProject refStream: smartRefStrm change the object due to conventions that have changed on the project level. (sent to all objects in the incoming project) Here is the calling sequence for storing out a Project: Project saveAs Project storeOnServer Project storeOnServerWithProgressInfo Project storeOnServerInnards Project exportSegmentFileName:directory: Project exportSegmentWithChangeSet:fileName:directory: ImageSegment writeForExportWithSources:inDirectory:changeSet: --------- Isolation (not used any more) When you accept a method, the entire system feels the change, except projects that are "isolated". In an isolated project, all new global variables (including new classes) arestored in the project-local environment, and all changes to preexisting classes are revoked when you leave the project. When you enter another project, that project's changes are invoked. Invocation and revocation are handled efficiently by swapping pointers. To make a project be isolated, choose 'isolate changes of this project' from the 'changes...' section of the screen menu. You can use an isolated project for making dangerous change to a system, and you can get out if it crashes. A foreign application can have the separate environment it wants. Also, you can freeze part of the system for a demo that you don't want to disturb. An isolated project shares methods with all subprojects inside it, unless they are isolated themselves. Each isolated project is the head of a tree of projects with which it shares all methods. You may 'assert' all changes ever made in the current project to take effect above this project. This amounts to exporting all the globals in the current environment, and zapping the revocation lists to that the current state of the world will remain in force upon exit from this project. [Later: A project may be 'frozen'. Asserts do not apply to it after that. (Great for demos.) You should be informed when an assert was blocked in a frozen project.] Class definitions are layered by the isolation mechanism. You are only allowed to change the shape of a class in projects that lie within its isolation scope. All versions of the methods are recompiled, in all projects. If you remove an inst var that is in use in an isolated project, it will become an Undeclared global. It is best not to remove an inst var when it is being used in another isolated project. [If we recompile them all, why can't we diagnose the problem before allowing the change??] Senders and Implementors do not see versions of a method in isolated projects. [again, we might want to make this possible at a cost]. When you ask for versions of a method, you will not get the history in other isolated projects. Moving methods and classes between changeSets, and merging changeSets has no effect on which methods are in force. But, when you look at a changeSet from a different isolated project, the methods will contain code that is not in force. A changeSet is just a list of method names, and does not keep separate copies of any code. When finer grained assertion is needed, use the method (aProject assertClass: aClass from: thisProject warn: warnConflicts). How isolated changes work: The first time a class changes, store its MethodDictionary object. Keep parallel arrays of associations to Classes and MethodDictionaries. Traverse these and install them when you enter an "ioslated project". When you leave, store this project's own MethodDictionaries there. To do an assert, we must discover which methods changed here, and which changed only in the project we are asserting into. There is one copy of the 'virgin' method dictionaries in the system. It is always being temporarily stored by the currently inForce isolated project. isolatedHead - true for the top project, and for each isolated project. false or nil for any subproject that shares all methods with its parent project. inForce - true if my methods are installed now. false if I am dormant. [is this equivalent to self == Project Current?] classArray - list of associations to classes methodDictArray - the method dictionaries of those classes before we started changing methods. They hang onto the original compiledMethods. (If this project is dormant, it contains the method dictionaries of those classes as they will be here, in this project). orgArray - the class organizations of the classes in classArray. UsingIsolation (class variable) - No longer used. When you want to save a project in export format from within that very project, it gets tricky. We set two flags in parentProject, exit to it, and let parentProject write the project. ProjectViewMorph in parentProject checks in its step method, does the store, clears the flags, and reenters the subProject. ! !Project class methodsFor: 'class initialization' stamp: 'RAA 12/17/2000 12:37'! rebuildAllProjects "Project rebuildAllProjects" AllProjects _ nil. self allProjects.! ! !Project class methodsFor: 'utilities' stamp: 'jla 5/28/2001 21:48'! allProjectsOrdered "Answer a list of all projects in hierarchical order, depth first" | allProjects | allProjects _ OrderedCollection new. Project topProject withChildrenDo: [:p | allProjects add: p]. ^ allProjects " Project allProjectsOrdered "! ! !Project class methodsFor: 'utilities' stamp: 'sw 11/24/2002 10:57'! buildJumpToMenu: menu "Make the supplied menu offer a list of potential projects, consisting of: * The previous-project chain * The next project, if any * The parent project, if any * All projects, alphabetically or hierarchically" | prev listed i next toAdd | listed _ OrderedCollection with: CurrentProject. i _ 0. "The previous Project chain" prev _ CurrentProject previousProject. [(prev ~~ nil and: [(listed includes: prev) not])] whileTrue: [i _ i + 1. listed add: prev. self addItem: prev name , ' (back ' , i printString , ')' toMenu: menu selection: ('%back' , i printString) project: prev. prev _ prev previousProject]. i > 0 ifTrue: [menu addLine]. "Then the next Project" (((next _ CurrentProject nextProject) ~~ nil) and: [(listed includes: next) not]) ifTrue: [self addItem: (next name, ' (forward 1)') toMenu: menu selection: next name project: next]. next ~~ nil ifTrue: [menu addLine]. "Then the parent" CurrentProject isTopProject ifFalse: [self addItem: CurrentProject parent name , ' (parent)' toMenu: menu selection: #parent project: CurrentProject parent. menu addLine]. "Finally all the projects, in hierarchical or alphabetical order:" (Preferences alphabeticalProjectMenu ifTrue: [Project allNamesAndProjects] ifFalse: [Project hierarchyOfNamesAndProjects]) do: [:aPair | toAdd _ aPair last isCurrentProject ifTrue: [aPair first, ' (current)'] ifFalse: [aPair first]. self addItem: toAdd toMenu: menu selection: aPair first project: aPair last]. ^ menu! ! !Project class methodsFor: 'utilities' stamp: 'sw 9/12/2001 23:05'! chooseNaturalLanguage "Have the current project choose a new natural language" self current chooseNaturalLanguage! ! !Project class methodsFor: 'utilities' stamp: 'jla 5/28/2001 21:43'! hierarchyOfNamesAndProjects "Answer a list of all project names, with each entry preceded by white space commensurate with its depth beneath the top project" ^ self allProjectsOrdered collect: [:project | Array with: project nameAdjustedForDepth with: project]! ! !Project class methodsFor: 'utilities' stamp: 'dtl 5/22/2004 16:13'! interruptName: labelString "Create a Notifier on the active scheduling process with the given label." | preemptedProcess projectProcess suspendingList | Smalltalk isMorphic ifFalse: [^ ScheduledControllers interruptName: labelString]. ActiveHand ifNotNil:[ActiveHand interrupted]. ActiveWorld _ World. "reinstall active globals" ActiveHand _ World primaryHand. ActiveHand interrupted. "make sure this one's interrupted too" ActiveEvent _ nil. projectProcess _ self uiProcess. "we still need the accessor for a while" preemptedProcess _ Processor preemptedProcess. "Only debug preempted process if its priority is >= projectProcess' priority" preemptedProcess priority < projectProcess priority ifTrue:[ (suspendingList _ projectProcess suspendingList) == nil ifTrue: [projectProcess == Processor activeProcess ifTrue: [projectProcess suspend]] ifFalse: [suspendingList remove: projectProcess ifAbsent: []. projectProcess offList]. preemptedProcess _ projectProcess. ] ifFalse:[ preemptedProcess _ projectProcess suspend offList. ]. Debugger openInterrupt: labelString onProcess: preemptedProcess ! ! !Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 20:34'! jumpToProject "Project jumpToProject" "Present a list of potential projects and enter the one selected." self jumpToSelection: (self buildJumpToMenu: CustomMenu new) startUpLeftFlush! ! !Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'! jumpToSelection: selection "Enter the project corresponding to this menu selection." "Project jumpToProject" | nBack prev pr | selection ifNil: [^ self]. (selection beginsWith: '%back') ifTrue: [nBack _ (selection copyFrom: 6 to: selection size) asNumber. prev _ CurrentProject previousProject. 1 to: nBack-1 do: [:i | prev ifNotNil: [prev _ prev previousProject]]. prev ifNotNil: [prev enter: true revert: false saveForRevert: false]]. selection = #parent ifTrue: [CurrentProject parent enter: false revert: false saveForRevert: false. ^ self]. (pr _ Project namedWithDepth: selection) ifNil: [^ self]. pr enter: false revert: false saveForRevert: false! ! !Project class methodsFor: 'utilities' stamp: 'jla 4/2/2001 15:57'! namedWithDepth: projName "Answer the project with the given name, or nil if there is no project of that given name." "(Project named: 'New Changes') enter" ^ self allProjects detect: [:proj | proj name = projName or: [proj nameAdjustedForDepth = projName]] ifNone: [nil]! ! !Project class methodsFor: 'utilities' stamp: 'sbw 4/13/2003 12:53'! projectHierarchy "Answer a string representing all the projects in the system in hierarchical order." "Project projectHierarchy" ^ String streamContents: [:aStream | self hierarchyOfNamesAndProjects do: [:aPair | aStream nextPutAll: aPair first; cr]]! ! !Project class methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:15'! removeAll: projects "Project removeAll: (Project allSubInstances copyWithout: Project current)" AllProjects _ nil. Smalltalk garbageCollect. ProjectHistory currentHistory initialize. projects do: [:project | Project deletingProject: project. StandardScriptingSystem removePlayersIn: project]. Smalltalk garbageCollect. Smalltalk garbageCollect. ! ! !Project class methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:22'! removeAllButCurrent "Project removeAllButCurrent" AllProjects _ nil. Smalltalk garbageCollect. self removeAll: (Project allSubInstances copyWithout: Project current). AllProjects _ nil. Smalltalk garbageCollect. Smalltalk garbageCollect. Project rebuildAllProjects. ^AllProjects! ! !Project class methodsFor: 'utilities' stamp: 'mir 6/21/2001 15:44'! versionForFileName: version "Project versionForFileName: 7" | v | ^String streamContents:[:s| v _ version printString. v size < 3 ifTrue:[v _ '0', v]. v size < 3 ifTrue:[v _ '0', v]. s nextPutAll: v. ] ! ! !Project class methodsFor: 'squeaklet on server' stamp: 'nb 6/17/2003 12:25'! enterIfThereOrFind: aProjectName | newProject | newProject _ Project named: aProjectName. newProject ifNotNil: [^newProject enter]. ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ [ newProject _ CurrentProject fromMyServerLoad: aProjectName ] on: ProjectViewOpenNotification do: [ :ex | ex resume: false] "we probably don't want a project view morph in this case" ]. newProject ifNotNil: [^newProject enter]. Beeper beep.! ! !Project class methodsFor: 'squeaklet on server' stamp: 'mir 2/6/2004 17:04'! fromUrl: urlString "Load the project, and make a thumbnail to it in the current project. Replace the old one if necessary. Project fromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/Squeak_Easy.pr.gz'. " | pair projName proj triple serverDir projectFilename serverUrl absoluteUrl | Project canWeLoadAProjectNow ifFalse: [^ self]. "serverFile _ HTTPLoader default contentStreamFor: urlString." absoluteUrl := (Url schemeNameForString: urlString) ifNil: [urlString asUrlRelativeTo: FileDirectory default url asUrl] ifNotNil: [Url absoluteFromText: urlString]. projectFilename _ absoluteUrl path last. triple _ Project parseProjectFileName: projectFilename unescapePercents. projName _ triple first. (proj _ Project named: projName) ifNotNil: ["it appeared" ^ ProjectEntryNotification signal: proj]. serverUrl _ (absoluteUrl copy path: (absoluteUrl path copyWithout: absoluteUrl path last)) toText. serverDir _ ServerDirectory serverForURL: serverUrl. serverDir ifNil: ["we just have a url, no dedicated project server" ProjectLoading installRemoteNamed: projectFilename from: absoluteUrl toText unescapePercents named: projName in: CurrentProject.]. pair _ self mostRecent: projectFilename onServer: serverDir. "Pair first is name exactly as it is on the server" pair first ifNil: [^self openBlankProjectNamed: projName]. ProjectLoading installRemoteNamed: pair first from: serverDir named: projName in: CurrentProject.! ! !Project class methodsFor: 'squeaklet on server' stamp: 'mir 8/8/2001 17:57'! loaderUrl "Return a url that will allow to launch a project in a browser by composing a url like ?" ^AbstractLauncher extractParameters at: 'LOADER_URL' ifAbsent: [nil].! ! !Project class methodsFor: 'squeaklet on server' stamp: 'gm 2/16/2003 20:50'! openBlankProjectNamed: projName | proj projViewer | proj _ Project newMorphicOn: nil. proj changeSet name: projName. proj world addMorph: ( TextMorph new beAllFont: ((TextStyle default fontOfSize: 26) emphasized: 1); color: Color red; contents: 'Welcome to a new project - ',projName ). CurrentProjectRefactoring currentBeParentTo: proj. projViewer _ (CurrentProject findProjectView: projName) ifNil: [^proj]. (projViewer owner isSystemWindow) ifTrue: [ projViewer owner model: proj]. ^ projViewer project: proj! ! !Project class methodsFor: 'squeaklet on server' stamp: 'ar 2/27/2001 13:43'! projectExtension ^'pr'! ! !Project class methodsFor: 'squeaklet on server' stamp: 'RAA 2/19/2001 07:37'! squeakletDirectory | squeakletDirectoryName | squeakletDirectoryName _ 'Squeaklets'. (FileDirectory default directoryExists: squeakletDirectoryName) ifFalse: [ FileDirectory default createDirectory: squeakletDirectoryName ]. ^FileDirectory default directoryNamed: squeakletDirectoryName! ! !ProjectEntryNotification class methodsFor: 'as yet unclassified' stamp: 'ajh 1/22/2003 23:52'! signal: aProject | ex | ex := self new. ex projectToEnter: aProject. ^ex signal: 'Entering ',aProject printString! ! !ProjectHistory class methodsFor: 'as yet unclassified' stamp: 'nk 7/30/2004 21:51'! currentHistory ^CurrentHistory ifNil: [CurrentHistory := self new]! ! !ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'! hideSplashMorph SplashMorph ifNil:[^self]. self showSplash ifFalse: [^self]. SplashMorph delete. World submorphs do:[:m| m visible: true]. "show all" ! ! !ProjectLauncher methodsFor: 'running' stamp: 'ar 3/16/2001 12:42'! installProjectFrom: loader self showSplashMorph. [[[ loader installProject ] on: ProjectViewOpenNotification do:[:ex| ex resume: false] "no project view in plugin launcher" ] on: ProgressInitiationException "no 'reading aStream' nonsense" do:[:ex| ex sendNotificationsTo: [ :min :max :curr |]] ] on: ProjectEntryNotification "hide splash morph when entering project" do:[:ex| self hideSplashMorph. ex pass].! ! !ProjectLauncher methodsFor: 'running' stamp: 'mir 4/3/2001 15:15'! showSplashMorph SplashMorph ifNil:[^self]. self showSplash ifFalse: [^self]. World submorphs do:[:m| m visible: false]. "hide all" World addMorphCentered: SplashMorph. World displayWorldSafely.! ! !ProjectLauncher methodsFor: 'running' stamp: 'fc 3/12/2004 15:28'! startUp World ifNotNil: [World install]. Utilities authorName: ''. Preferences eToyLoginEnabled ifFalse:[^self startUpAfterLogin]. self doEtoyLogin.! ! !ProjectLauncher methodsFor: 'running' stamp: 'sw 3/4/2004 22:45'! startUpAfterLogin | scriptName loader isUrl | self setupFlaps. Preferences readDocumentAtStartup ifTrue: [ HTTPClient isRunningInBrowser ifTrue:[ self setupFromParameters. scriptName _ self parameterAt: 'src'. CodeLoader defaultBaseURL: (self parameterAt: 'Base'). ] ifFalse:[ scriptName _ (SmalltalkImage current getSystemAttribute: 2) ifNil:['']. scriptName isEmpty ifFalse:[ "figure out if script name is a URL by itself" isUrl _ (scriptName asLowercase beginsWith:'http://') or:[ (scriptName asLowercase beginsWith:'file://') or:[ (scriptName asLowercase beginsWith:'ftp://')]]. isUrl ifFalse:[scriptName _ 'file:',scriptName]]. ]. ] ifFalse: [ scriptName := '' ]. scriptName isEmptyOrNil ifTrue:[^Preferences eToyFriendly ifTrue: [self currentWorld addGlobalFlaps]]. loader _ CodeLoader new. loader loadSourceFiles: (Array with: scriptName). (scriptName asLowercase endsWith: '.pr') ifTrue:[self installProjectFrom: loader] ifFalse:[loader installSourceFiles]. ! ! !ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/24/2001 20:25'! initialize super initialize. showSplash _ true. HTTPClient isRunningInBrowser ifTrue: [whichFlaps _ 'etoy']! ! !ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/24/2001 15:51'! setupFlaps "Only called when the image has been launched in a browser. If I am requested to show etoy flaps, then remove any pre-existing shared flaps and put up the supplies flap only. if I am requested to show all flaps, then if flaps already exist, use them as is, else set up to show the default set of standard flaps." ((whichFlaps = 'etoy') or: [Preferences eToyFriendly]) ifTrue: [Flaps addAndEnableEToyFlaps]. whichFlaps = 'all' ifTrue: [Flaps sharedFlapsAllowed ifFalse: [Flaps enableGlobalFlaps]]! ! !ProjectLauncher methodsFor: 'initialization' stamp: 'mir 8/23/2002 14:52'! setupFromParameters (self includesParameter: 'showSplash') ifTrue: [showSplash _ (self parameterAt: 'showSplash') asUppercase = 'TRUE']. (self includesParameter: 'flaps') ifTrue: [whichFlaps _ (self parameterAt: 'flaps')]. ! ! !ProjectLauncher methodsFor: 'private' stamp: 'mir 4/3/2001 15:15'! showSplash ^showSplash! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:04'! cancelLogin "This is fine - we just proceed here. Later we may do something utterly different ;-)" ^self proceedWithLogin! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 9/5/2001 16:32'! doEtoyLogin "Pop up the eToy login if we have a server that provides us with a known user list" "Find us a server who could do eToy authentification for us" eToyAuthentificationServer _ (ServerDirectory localProjectDirectories, ServerDirectory servers values) detect:[:any| any hasEToyUserList] ifNone:[nil]. eToyAuthentificationServer "no server provides user information" ifNil:[^self startUpAfterLogin]. self prepareForLogin. EtoyLoginMorph loginAndDo:[:userName| self loginAs: userName] ifCanceled:[self cancelLogin].! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 9/5/2001 16:05'! loginAs: userName "Assuming that we have a valid user url; read its contents and see if the user is really there." | actualName userList | eToyAuthentificationServer ifNil:[ self proceedWithLogin. ^true]. userList _ eToyAuthentificationServer eToyUserList. userList ifNil:[ self inform: 'Sorry, I cannot find the user list. (this may be due to a network problem) Please hit Cancel if you wish to use Squeak.'. ^false]. "case insensitive search" actualName _ userList detect:[:any| any sameAs: userName] ifNone:[nil]. actualName isNil ifTrue:[ self inform: 'Unknown user: ',userName. ^false]. Utilities authorName: actualName. eToyAuthentificationServer eToyUserName: actualName. self proceedWithLogin. ^true! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/23/2001 22:06'! prepareForLogin "Prepare for login - e.g., hide everything so only the login morph is visible." World submorphsDo:[:m| m isLocked ifFalse:[m hide]]. "hide all those guys" World displayWorldSafely. ! ! !ProjectLauncher methodsFor: 'eToy login' stamp: 'ar 8/24/2001 15:17'! proceedWithLogin eToyAuthentificationServer _ nil. World submorphsDo:[:m| m show]. WorldState addDeferredUIMessage: [self startUpAfterLogin].! ! !ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:32'! splashMorph ^SplashMorph! ! !ProjectLauncher class methodsFor: 'accessing' stamp: 'ar 3/15/2001 23:33'! splashMorph: aMorph SplashMorph _ aMorph.! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'nk 8/30/2004 08:00'! bestAccessToFileName: aFileName andDirectory: aDirectoryOrURL | localDir schema dir | ((localDir _ Project squeakletDirectory) fileExists: aFileName) ifTrue: [^{localDir readOnlyFileNamed: aFileName. localDir}]. (aDirectoryOrURL isString) ifTrue: [ schema := Url schemeNameForString: aDirectoryOrURL. (schema isNil or: [schema = 'file']) ifTrue: [ dir := schema ifNil: [FileDirectory forFileName: (FileDirectory default fullNameFor: aDirectoryOrURL)] ifNotNil: [FileDirectory on: ((FileUrl absoluteFromText: aDirectoryOrURL) pathForDirectory)]] ifFalse: [^{(Project serverFileFromURL: aDirectoryOrURL) asStream. nil}]] ifFalse: [dir := aDirectoryOrURL]. ^{dir readOnlyFileNamed: aFileName. dir} ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 20:25'! installRemoteNamed: remoteFileName from: aServer named: otherProjectName in: currentProject | fileAndDir | "Find the current ProjectViewMorph, fetch the project, install in ProjectViewMorph without changing size, and jump into new project." ProgressNotification signal: '1:foundMostRecent'. fileAndDir _ self bestAccessToFileName: remoteFileName andDirectory: aServer. ^self openName: remoteFileName stream: fileAndDir first fromDirectory: fileAndDir second withProjectView: (currentProject findProjectView: otherProjectName). ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 20:25'! openFromDirectory: aDirectory andFileName: aFileName | fileAndDir | ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ ProgressNotification signal: '1:foundMostRecent'. fileAndDir _ self bestAccessToFileName: aFileName andDirectory: aDirectory. self openName: aFileName stream: fileAndDir first fromDirectory: fileAndDir second withProjectView: nil. ]! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 2/19/2001 08:22'! openFromFile: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView self error: 'use #openFromFile:fromDirectory:withProjectView:' ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'yo 3/1/2005 06:11'! openName: aFileName stream: preStream fromDirectory: aDirectoryOrNil withProjectView: existingView "Reconstitute a Morph from the selected file, presumed to be represent a Morph saved via the SmartRefStream mechanism, and open it in an appropriate Morphic world." | morphOrList proj trusted localDir projStream archive mgr projectsToBeDeleted baseChangeSet enterRestricted substituteFont numberOfFontSubstitutes exceptions | (preStream isNil or: [preStream size = 0]) ifTrue: [ ProgressNotification signal: '9999 about to enter project'. "the hard part is over" ^self inform: 'It looks like a problem occurred while getting this project. It may be temporary, so you may want to try again,' translated ]. ProgressNotification signal: '2:fileSizeDetermined ',preStream size printString. preStream isZipArchive ifTrue:[ archive _ ZipArchive new readFrom: preStream. projStream _ self projectStreamFromArchive: archive] ifFalse:[projStream _ preStream]. trusted _ SecurityManager default positionToSecureContentsOf: projStream. trusted ifFalse: [enterRestricted := (preStream isTypeHTTP or: [aFileName isNil]) ifTrue: [Preferences securityChecksEnabled] ifFalse: [Preferences standaloneSecurityChecksEnabled]. enterRestricted ifTrue: [SecurityManager default enterRestrictedMode ifFalse: [preStream close. ^ self]]]. localDir _ Project squeakletDirectory. aFileName ifNotNil: [ (aDirectoryOrNil isNil or: [aDirectoryOrNil pathName ~= localDir pathName]) ifTrue: [ localDir deleteFileNamed: aFileName. (localDir fileNamed: aFileName) binary nextPutAll: preStream contents; close. ]. ]. morphOrList _ projStream asUnZippedStream. preStream sleep. "if ftp, let the connection close" ProgressNotification signal: '3:unzipped'. ResourceCollector current: ResourceCollector new. baseChangeSet _ ChangeSet current. self useTempChangeSet. "named zzTemp" "The actual reading happens here" substituteFont := Preferences standardEToysFont copy. numberOfFontSubstitutes := 0. exceptions := Set new. [[morphOrList _ morphOrList fileInObjectAndCodeForProject] on: FontSubstitutionDuringLoading do: [ :ex | exceptions add: ex. numberOfFontSubstitutes := numberOfFontSubstitutes + 1. ex resume: substituteFont ]] ensure: [ ChangeSet newChanges: baseChangeSet]. mgr _ ResourceManager new initializeFrom: ResourceCollector current. mgr fixJISX0208Resource. mgr registerUnloadedResources. archive ifNotNil:[mgr preLoadFromArchive: archive cacheName: aFileName]. (preStream respondsTo: #close) ifTrue:[preStream close]. ResourceCollector current: nil. ProgressNotification signal: '4:filedIn'. ProgressNotification signal: '9999 about to enter project'. "the hard part is over" (morphOrList isKindOf: ImageSegment) ifTrue: [ proj _ morphOrList arrayOfRoots detect: [:mm | mm isKindOf: Project] ifNone: [^self inform: 'No project found in this file']. proj projectParameters at: #substitutedFont put: ( numberOfFontSubstitutes > 0 ifTrue: [substituteFont] ifFalse: [#none]). proj projectParameters at: #MultiSymbolInWrongPlace put: false. "Yoshiki did not put MultiSymbols into outPointers in older images!!" morphOrList arrayOfRoots do: [:obj | obj fixUponLoad: proj seg: morphOrList "imageSegment"]. (proj projectParameters at: #MultiSymbolInWrongPlace) ifTrue: [ morphOrList arrayOfRoots do: [:obj | (obj isKindOf: Set) ifTrue: [obj rehash]]]. proj resourceManager: mgr. "proj versionFrom: preStream." proj lastDirectory: aDirectoryOrNil. CurrentProjectRefactoring currentBeParentTo: proj. projectsToBeDeleted _ OrderedCollection new. existingView ifNil: [ Smalltalk isMorphic ifTrue: [ proj createViewIfAppropriate. ] ifFalse: [ ChangeSorter allChangeSets add: proj changeSet. ProjectView openAndEnter: proj. "Note: in MVC we get no further than the above" ]. ] ifNotNil: [ (existingView project isKindOf: DiskProxy) ifFalse: [ existingView project changeSet name: ChangeSet defaultName. projectsToBeDeleted add: existingView project. ]. (existingView owner isSystemWindow) ifTrue: [ existingView owner model: proj ]. existingView project: proj. ]. ChangeSorter allChangeSets add: proj changeSet. Project current projectParameters at: #deleteWhenEnteringNewProject ifPresent: [ :ignored | projectsToBeDeleted add: Project current. Project current removeParameter: #deleteWhenEnteringNewProject. ]. projectsToBeDeleted isEmpty ifFalse: [ proj projectParameters at: #projectsToBeDeleted put: projectsToBeDeleted. ]. ^ ProjectEntryNotification signal: proj ]. (morphOrList isKindOf: SqueakPage) ifTrue: [ morphOrList _ morphOrList contentsMorph ]. (morphOrList isKindOf: PasteUpMorph) ifFalse: [^ self inform: 'This is not a PasteUpMorph or exported Project.' translated]. (Project newMorphicOn: morphOrList) enter ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'ar 2/27/2001 14:33'! projectStreamFromArchive: archive | ext prFiles entry unzipped | ext _ FileDirectory dot, Project projectExtension. prFiles _ archive members select:[:any| any fileName endsWith: ext]. prFiles isEmpty ifTrue:[^'']. entry _ prFiles first. unzipped _ RWBinaryOrTextStream on: (ByteArray new: entry uncompressedSize). entry extractTo: unzipped. ^unzipped reset! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'RAA 2/20/2001 20:26'! thumbnailFromUrl: urlString | fileName fileAndDir | "Load the project, and make a thumbnail to it in the current project. ProjectLoading thumbnailFromUrl: 'http://www.squeak.org/Squeak2.0/2.7segments/SqueakEasy.extSeg'. " Project canWeLoadAProjectNow ifFalse: [^ self]. ComplexProgressIndicator new targetMorph: nil; historyCategory: 'project loading'; withProgressDo: [ ProgressNotification signal: '1:foundMostRecent'. fileName _ (urlString findTokens: '/') last. fileAndDir _ self bestAccessToFileName: fileName andDirectory: urlString. self openName: fileName stream: fileAndDir first fromDirectory: fileAndDir second withProjectView: nil. ] ! ! !ProjectLoading class methodsFor: 'as yet unclassified' stamp: 'sd 5/23/2003 15:16'! useTempChangeSet "While reading the project in, use the temporary change set zzTemp" | zz | zz _ ChangeSorter changeSetNamed: 'zzTemp'. zz ifNil: [zz _ ChangeSorter basicNewChangeSet: 'zzTemp']. ChangeSet newChanges: zz.! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 8/23/2001 18:10'! checkForRebuild | lastScreenMode flapsSuppressed | lastScreenMode _ ScreenController lastScreenModeSelected ifNil: [false]. flapsSuppressed _ CurrentProjectRefactoring currentFlapsSuppressed. ((self valueOfProperty: #currentNavigatorVersion) = self currentNavigatorVersion and: [lastScreenMode = self inFullScreenMode and: [flapsSuppressed = self inFlapsSuppressedMode and: [(self valueOfProperty: #includeSoundControlInNavigator) = Preferences includeSoundControlInNavigator]]]) ifFalse: [ self setProperty: #includeSoundControlInNavigator toValue: Preferences includeSoundControlInNavigator. self setProperty: #flapsSuppressedMode toValue: flapsSuppressed. self setProperty: #showingFullScreenMode toValue: lastScreenMode. self setProperty: #currentNavigatorVersion toValue: self currentNavigatorVersion. self removeAllMorphs. self addButtons. ]. ! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'bf 10/8/2004 13:21'! currentNavigatorVersion ^29 "since these guys get saved, we fix them up if they are older versions"! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'yo 7/2/2004 20:01'! makeButton: aString balloonText: anotherString for: aSymbol self flag: #yo. "In principle, this method shouldn't call #translated." ^ SimpleButtonDelayedMenuMorph new target: self; borderColor: #raised; color: self colorForButtons; label: aString translated font: self fontForButtons; setBalloonText: anotherString translated; actionSelector: aSymbol! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'dgd 8/30/2003 21:59'! orientationString ^ (self orientedVertically ifTrue: [''] ifFalse: ['']) , 'vertical orientation' translated! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/6/2001 14:16'! retractIfAppropriate mouseInside _ false. self positionVertically. ! ! !ProjectNavigationMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/17/2001 12:44'! showMenuFor: aSymbol event: evt (aSymbol == #publishProject or: [aSymbol == #publishProjectSimple]) ifTrue: [ self doPublishButtonMenuEvent: evt. ^true "we did show the menu" ]. (aSymbol == #findAProject or: [aSymbol == #findAProjectSimple]) ifTrue: [ self doFindButtonMenuEvent: evt. ^true "we did show the menu" ]. ^false ! ! !ProjectNavigationMorph methodsFor: 'event handling' stamp: 'RAA 6/29/2000 11:11'! handlesMouseOver: evt ^true! ! !ProjectNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange! ! !ProjectNavigationMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 21:30'! initialize "initialize the state of the receiver" super initialize. "" self layoutInset: 6; hResizing: #shrinkWrap; vResizing: #shrinkWrap; useRoundedCorners. mouseInside _ false. self addButtons! ! !ProjectNavigationMorph methodsFor: 'stepping and presenter' stamp: 'RAA 8/23/2001 18:11'! step | wb | owner ifNil: [^ self]. (self ownerThatIsA: HandMorph) ifNotNil: [^self]. self checkForRebuild. owner == self world ifTrue: [ owner addMorphInLayer: self. wb _ self worldBounds. self left < wb left ifTrue: [self left: wb left]. self right > wb right ifTrue: [self right: wb right]. self positionVertically. ].! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 1/2/2004 13:54'! chooseLanguage Project current chooseNaturalLanguage! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'dgd 8/27/2004 18:35'! doFindButtonMenuEvent: evt | menu selection | menu _ CustomMenu new. menu add: 'find a project' translated action: [self findAProjectSimple]; add: 'find a project (more places)' translated action: [self findAProject]; add: 'find any file' translated action: [self findAnything]; add: 'search the SuperSwiki' translated action: [self findSomethingOnSuperSwiki]. selection _ menu build startUpCenteredWithCaption: 'Find options' translated. selection ifNil: [^self]. selection value. ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/17/2005 15:40'! doNewPainting | w f | w _ self world. w assureNotPaintingElse: [^ self]. (f _ self owner flapTab) ifNotNil: [f hideFlap]. w makeNewDrawing: (self primaryHand lastEvent copy setPosition: w center) ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/10/2005 15:42'! doPublishButtonMenuEvent: evt | menu selection | menu _ CustomMenu new. menu add: 'Publish' translated action: [self publishProject]; add: 'Publish As...' translated action: [self publishProjectAs]; add: 'Publish to Different Server' translated action: [self publishDifferent]; add: 'edit project info' translated action: [self editProjectInfo]. selection _ menu build startUpCenteredWithCaption: 'Publish options' translated. selection ifNil: [^self]. selection value. ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/17/2001 12:27'! findAProject FileList2 morphicViewProjectLoader2InWorld: self world reallyLoad: true dirFilterType: #initialDirectoryList! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/17/2001 12:27'! findAProjectSimple FileList2 morphicViewProjectLoader2InWorld: self world reallyLoad: true dirFilterType: #limitedSuperSwikiDirectoryList! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'nb 6/17/2003 12:25'! getNewerVersionIfAvailable (self world ifNil: [^Beeper beep]) project loadFromServer: true. ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'nb 6/17/2003 12:25'! nextProject Project advanceToNextProject. Beeper beep.! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'nb 6/17/2003 12:25'! previousProject Project returnToPreviousProject. CurrentProjectRefactoring exitCurrentProject. "go to parent if no previous" Beeper beep.! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 5/16/2001 17:44'! publishDifferent self publishStyle: #initialDirectoryList forgetURL: true withRename: false ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'yo 2/17/2005 14:55'! publishProject self world paintBoxOrNil ifNotNil: [ (self confirm: 'You seem to be painting a sketch. Do you continue and publish the project with the paint tool?' translated) ifFalse: [^ self]. ]. self publishStyle: #limitedSuperSwikiPublishDirectoryList forgetURL: false withRename: false! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 6/25/2001 16:53'! publishProjectAs self publishStyle: #limitedSuperSwikiPublishDirectoryList forgetURL: false withRename: true! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'mir 11/15/2004 10:25'! publishStyle: aSymbol forgetURL: aBoolean withRename: renameBoolean | w saveOwner primaryServer rename | w _ self world ifNil: [^Beeper beep]. w setProperty: #SuperSwikiPublishOptions toValue: aSymbol. primaryServer _ w project primaryServerIfNil: [nil]. rename _ ((primaryServer notNil and: [primaryServer acceptsUploads]) not) or: [renameBoolean]. w setProperty: #SuperSwikiRename toValue: rename. saveOwner _ owner. self delete. [w project storeOnServerShowProgressOn: self forgetURL: aBoolean | rename] ensure: [saveOwner addMorphFront: self]! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'sw 3/3/2004 14:19'! quitSqueak "Obtain a confirmation from the user, and if the answer is true, quite Squeak summarily" (self confirm: 'Are you sure you want to Quit Squeak?' translated) ifFalse: [^ self]. SmalltalkImage current snapshot: false andQuit: true ! ! !ProjectNavigationMorph methodsFor: 'the actions' stamp: 'RAA 2/19/2001 09:52'! undoLastCommand self world commandHistory undoLastCommand! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'yo 2/10/2005 15:37'! buttonFind "Answer a button for finding/loading projects" ^ self makeButton: 'FIND' balloonText: 'Click here to find a project. Hold down this button to reveal additional options.' translated for: #findAProjectSimple ! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'yo 2/10/2005 19:27'! buttonLanguage "Answer a button for changing the language" | myButton m | myButton _ self makeButton: '' balloonText: 'Click here to choose your language.' translated for: #chooseLanguage. myButton addMorph: (m _ self languageIcon asMorph lock). myButton extent: m extent + (myButton borderWidth + 6). m position: myButton center - (m extent // 2). ^ myButton! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 7/16/2001 14:06'! buttonNewProject ^self makeButton: 'NEW' balloonText: 'Start a new project' for: #newProject ! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'yo 2/10/2005 15:42'! buttonPublish "Answer a button for publishing the project" ^ self makeButton: 'PUBLISH IT!!' translated balloonText: 'Click here to save a project. Hold down this button to reveal additional publishing options' translated for: #publishProject! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'RAA 2/19/2001 09:51'! buttonUndo ^self makeButton: 'Undo' balloonText: 'Undo the last command' for: #undoLastCommand ! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'dgd 8/27/2004 18:43'! findSomethingOnSuperSwiki | projectServers server index | projectServers := ServerDirectory projectServers. projectServers isEmpty ifTrue: [^self]. projectServers size = 1 ifTrue: [server := projectServers first] ifFalse: [index := (PopUpMenu labelArray: (projectServers collect: [:each | (ServerDirectory nameForServer: each) translatedIfCorresponds]) lines: #()) startUpWithCaption: 'Choose a super swiki:' translated. index > 0 ifTrue: [server := projectServers at: index] ifFalse: [^self]]. EToyProjectQueryMorph onServer: server! ! !ProjectNavigationMorph methodsFor: 'the buttons' stamp: 'bf 10/8/2004 12:47'! languageIcon ^ (ColorForm extent: 19@18 depth: 4 fromArray: #( 4294967295 4294967295 4293918720 4294967206 2183331839 4293918720 4294946286 3972145919 4293918720 4294631150 3430031919 4293918720 4289588973 3396477476 4293918720 4292799965 3399692836 4293918720 4208913868 724784466 804257792 4141735107 858993445 804257792 4140616899 1127429205 804257792 4174171340 3006481493 804257792 4174171340 3274982741 804257792 4170435788 3409204562 804257792 4280497100 1429493074 4293918720 4280431429 1429558562 4293918720 4294059093 1431654959 4293918720 4294919237 1431446271 4293918720 4294967074 572719103 4293918720 4294967295 4294967295 4293918720) offset: 0@0) colorsFromArray: #(#(0.0 0.0 0.0) #(1.0 1.0 1.0) #(0.376 0.376 0.784) #(0.357 0.357 0.733) #(0.231 0.231 0.474) #(0.494 0.494 0.964) #(0.498 0.498 0.933) #(0.376 0.376 0.706) #(0.419 0.419 0.78) #(0.415 0.415 0.776) #(0.595 0.595 0.972) #(0.638 0.638 0.968) #(0.654 0.654 0.96) #(0.686 0.686 0.96) #(0.71 0.71 0.964) #( ) )! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'dgd 9/1/2003 11:36'! buttonSound | myButton m | myButton _ RectangleMorph new borderWidth: 1; cornerStyle: #rounded; borderColor: #raised; color: self colorForButtons; setBalloonText: 'Change sound volume' translated; on: #mouseDown send: #soundDownEvt:morph: to: self; on: #mouseStillDown send: #soundStillDownEvt:morph: to: self; on: #mouseUp send: #soundUpEvt:morph: to: self; yourself. myButton addMorph: (m _ self speakerIcon lock). myButton extent: m extent + (myButton borderWidth + 6). m position: myButton center - (m extent // 2). ^myButton ! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:52'! getSoundVolume ^SoundPlayer soundVolume average! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:49'! setSoundVolume: x SoundPlayer setVolumeLeft: x volumeRight: x. ! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:57'! soundDownEvt: a morph: b soundSlider ifNotNil: [soundSlider delete]. (soundSlider _ RectangleMorph new) setProperty: #morphicLayerNumber toValue: 1; extent: b width @ (b width * 3); color: self colorForButtons; borderColor: #raised; bottomLeft: b boundsInWorld origin. soundSlider addMorph: ( RectangleMorph new color: self colorForButtons; borderColor: #raised; extent: b width @ 8; center: soundSlider center x @ (soundSlider bottom - (soundSlider height * self getSoundVolume) asInteger) ). soundSlider openInWorld.! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'ar 8/23/2001 23:49'! soundStillDownEvt: evt morph: b | y pct | soundSlider ifNil: [^self]. y _ evt hand position y. (y between: soundSlider top and: soundSlider bottom) ifTrue: [ pct _ (soundSlider bottom - y) asFloat / soundSlider height. self setSoundVolume: pct. soundSlider firstSubmorph top: y - 5. ]. ! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'gk 2/24/2004 23:29'! soundUpEvt: a morph: b soundSlider ifNotNil: [soundSlider delete]. soundSlider _ nil. Beeper beep ! ! !ProjectNavigationMorph methodsFor: '*sound' stamp: 'RAA 8/23/2001 17:05'! speakerIcon ^ImageMorph new image: ( (Form extent: 19@18 depth: 8 fromArray: #( 0 0 1493172224 0 0 0 0 1493172224 0 0 0 138 1493172224 0 0 0 35509 2315255808 0 0 0 9090522 2315255808 0 0 0 2327173887 2315255819 0 0 138 3051028442 2315255819 0 0 1505080590 4294957786 2315255808 184549376 0 3053453311 4292532917 1493172224 184549376 0 1505080714 3048584629 1493172224 184549376 0 9079434 3048584629 1493172224 184549376 0 138 2327164341 1493172235 0 0 0 2324346293 1493172235 0 0 0 9079477 1493172224 0 0 0 35466 1493172224 0 0 0 138 0 0 0 0 0 0 0 0 0 0 0 0 0) offset: 0@0) ); setBalloonText: 'Quiet'; on: #mouseUp send: #yourself to: 1 ! ! !ProjectNavigationMorph methodsFor: 'buttons' stamp: 'mir 2/29/2004 14:53'! makeTheButtons ^{ self buttonNewProject. self buttonShare. self buttonPrev. self buttonNext. self buttonPublish. self buttonNewer. self buttonTell. self buttonFind. self buttonFullScreen. "self buttonFlaps." self buttonPaint. }, ( Preferences includeSoundControlInNavigator ifTrue: [{self buttonSound}] ifFalse: [#()] ), { self buttonLanguage. self buttonUndo. self buttonQuit. } ! ! !ProjectNavigationMorph class methodsFor: 'as yet unclassified' stamp: 'mir 8/22/2001 18:09'! preferredNavigator "Preferences eToyFriendly ifTrue: [^KidNavigationMorph]." ^ProjectNavigationMorph! ! !ProjectPasswordNotification methodsFor: 'as yet unclassified' stamp: 'RAA 4/23/2001 16:47'! defaultAction self resume: ''! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'dgd 10/8/2003 19:44'! addControls | b r partsBinButton newButton | newButton _ ImageMorph new image: (World project makeThumbnail scaledToSize: 24@18). newButton on: #mouseDown send: #insertNewProject: to: self. newButton setBalloonText: 'Make a new Project' translated. (partsBinButton _ UpdatingThreePhaseButtonMorph checkBox) target: self; actionSelector: #togglePartsBinStatus; arguments: #(); getSelector: #getPartsBinStatus. (r _ AlignmentMorph newRow) color: Color transparent; borderWidth: 0; layoutInset: 0; wrapCentering: #center; cellPositioning: #topCenter; hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. b _ SimpleButtonMorph new target: self; color: self defaultColor darker; borderColor: Color black. r addMorphBack: (self wrapperFor: (b label: 'Okay' translated; actionSelector: #acceptSort)). b _ SimpleButtonMorph new target: self; color: self defaultColor darker; borderColor: Color black. r addMorphBack: (self wrapperFor: (b label: 'Cancel' translated; actionSelector: #delete)); addMorphBack: (self wrapperFor: (newButton)); addTransparentSpacerOfSize: 8 @ 0; addMorphBack: (self wrapperFor: partsBinButton); addMorphBack: (self wrapperFor: (StringMorph contents: 'Parts bin' translated) lock). self addMorphFront: r. ! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/24/2001 22:19'! clickFromSorterEvent: evt morph: aMorph | where what | (aMorph bounds containsPoint: evt cursorPoint) ifFalse: [^self]. evt isMouseUp ifFalse: [ evt shiftPressed ifFalse: [^evt hand grabMorph: aMorph]. ^self ]. evt shiftPressed ifTrue: [ where _ aMorph owner submorphs indexOf: aMorph ifAbsent: [nil]. what _ book threadName. WorldState addDeferredUIMessage: [ InternalThreadNavigationMorph openThreadNamed: what atIndex: where ] fixTemps. (Project named: (aMorph valueOfProperty: #nameOfThisProject)) enter. ]. ! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/4/2001 15:55'! insertNewProject: evt | newProj | [newProj _ Project newMorphicOn: nil.] on: ProjectViewOpenNotification do: [ :ex | ex resume: false]. EToyProjectDetailsMorph getFullInfoFor: newProj ifValid: [ evt hand attachMorph: (self sorterMorphForProjectNamed: newProj name) ] expandedFormat: false. ! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 2/4/2001 15:40'! morphsForMyContentsFrom: listOfPages sizedTo: sz | morphsForPageSorter | 'Assembling thumbnail images...' displayProgressAt: self cursorPoint from: 0 to: listOfPages size during: [:bar | morphsForPageSorter _ listOfPages withIndexCollect: [ :each :index | bar value: index. self sorterMorphForProjectNamed: each first ]. ]. ^morphsForPageSorter ! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'md 11/14/2003 17:09'! navigator: aThreadNavigator listOfPages: listOfPages | morphsForPageSorter pixelsAvailable pixelsNeeded scale | "a bit of fudging to try to outguess the layout mechanism and get best possible scale" pixelsAvailable _ Display extent - 130. pixelsAvailable _ pixelsAvailable x * pixelsAvailable y. pixelsNeeded _ 100@75. pixelsNeeded _ pixelsNeeded x * pixelsNeeded y * listOfPages size. scale _ (pixelsAvailable / pixelsNeeded min: 1) sqrt. sizeOfEachMorph _ (100@75 * scale) rounded. morphsForPageSorter _ self morphsForMyContentsFrom: listOfPages sizedTo: sizeOfEachMorph. morphsForPageSorter _ morphsForPageSorter reject: [ :each | each isNil]. self changeExtent: Display extent. self book: aThreadNavigator morphsToSort: morphsForPageSorter. pageHolder cursor: aThreadNavigator currentIndex; fullBounds; hResizing: #rigid. ! ! !ProjectSorterMorph methodsFor: 'as yet unclassified' stamp: 'RAA 5/10/2001 17:07'! sorterMorphForProjectNamed: projName | pvm proj | (proj _ Project named: projName) ifNil: [^nil]. pvm _ (InternalThreadNavigationMorph getThumbnailFor: proj) asMorph. pvm setProperty: #nameOfThisProject toValue: projName. pvm setBalloonText: projName. pvm on: #mouseDown send: #clickFromSorterEvent:morph: to: self. pvm on: #mouseUp send: #clickFromSorterEvent:morph: to: self. ^pvm ! ! !ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:54'! defaultBorderWidth "answer the default border width for the receiver" ^ 0 ! ! !ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.365 g: 0.634 b: 0.729! ! !ProjectSorterMorph methodsFor: 'initialization' stamp: 'dgd 2/17/2003 19:54'! initialize "initialize the state of the receiver" super initialize. "" self useRoundedCorners. pageHolder useRoundedCorners; borderWidth: 0; color: (self gridFormOrigin: 0 @ 0 grid: 16 @ 16 background: Color white line: Color blue muchLighter)! ! !ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 6/25/2001 12:40'! acceptsUploads ^acceptsUploads == true! ! !ProjectSwikiServer methodsFor: 'testing' stamp: 'mir 4/16/2001 17:42'! isProjectSwiki ^true! ! !ProjectSwikiServer methodsFor: 'initialize' stamp: 'mir 4/20/2001 18:43'! wakeUp! ! !ProjectSwikiServer methodsFor: 'accessing' stamp: 'mir 6/25/2001 12:40'! acceptsUploads: aBoolean acceptsUploads _ aBoolean! ! !ProjectViewMorph methodsFor: 'accessing' stamp: 'RAA 2/12/2001 14:47'! borderWidthForRounding ^1! ! !ProjectViewMorph methodsFor: 'accessing' stamp: 'di 6/6/2001 21:34'! thumbnail ^ project ifNotNil: [project thumbnail]! ! !ProjectViewMorph methodsFor: 'as yet unclassified' stamp: 'nk 6/9/2004 09:56'! expungeProject (self confirm: ('Do you really want to delete {1} and all its content?' translated format: {project name})) ifFalse: [^ self]. owner isSystemWindow ifTrue: [owner model: nil; delete]. ProjectHistory forget: project. Project deletingProject: project! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'raa 2/8/2001 10:40'! ensureImageReady self isTheRealProjectPresent ifFalse: [^self]. project thumbnail ifNil: [ image fill: image boundingBox rule: Form over fillColor: project defaultBackgroundColor. ^self ]. project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds" lastProjectThumbnail _ project thumbnail. self updateImageFrom: lastProjectThumbnail. project thumbnail ifNotNil: [project thumbnail hibernate]. image borderWidth: 1 ]. ! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/22/2003 13:14'! safeProjectName | projectName args | projectName := self valueOfProperty: #SafeProjectName ifAbsent: ['???']. self isTheRealProjectPresent ifFalse: [project class == DiskProxy ifTrue: [args := project constructorArgs. ((args isKindOf: Array) and: [args size = 1 and: [args first isString]]) ifTrue: [^args first]] ifFalse: [^projectName]]. self setProperty: #SafeProjectName toValue: project name. ^project name! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'gm 2/16/2003 20:34'! safeProjectName: aString self addProjectNameMorphFiller. self isTheRealProjectPresent ifFalse: [^self]. project renameTo: aString. self setProperty: #SafeProjectName toValue: project name. self updateNamePosition. (owner isSystemWindow) ifTrue: [owner setLabel: aString]! ! !ProjectViewMorph methodsFor: 'events' stamp: 'dgd 8/31/2003 18:40'! balloonText ^ 'Click here to enter the project named "{1}"' translated format: {project name}! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sumim 11/21/2003 13:43'! deletingProject: aProject "My project is being deleted. Delete me as well." self flag: #bob. "zapping projects" project == aProject ifTrue: [ self owner isSystemWindow ifTrue: [self owner model: nil; delete]. self delete].! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 3/17/2005 23:59'! doButtonAction "My inherent button action consists of entering the project I represent" self enter! ! !ProjectViewMorph methodsFor: 'events' stamp: 'md 10/22/2003 15:51'! enter "Enter my project." self world == self outermostWorldMorph ifFalse: [^Beeper beep]. "can't do this at the moment" project class == DiskProxy ifFalse: [(project world notNil and: [project world isMorph and: [project world hasOwner: self outermostWorldMorph]]) ifTrue: [^Beeper beep "project is open in a window already"]]. project class == DiskProxy ifTrue: ["When target is not in yet" self enterWhenNotPresent. "will bring it in" project class == DiskProxy ifTrue: [^self inform: 'Project not found']]. (owner isSystemWindow) ifTrue: [project setViewSize: self extent]. self showMouseState: 3. project enter: false revert: false saveForRevert: false! ! !ProjectViewMorph methodsFor: 'events' stamp: 'gm 2/16/2003 20:34'! enterAsActiveSubproject "Enter my project." project class == DiskProxy ifTrue: ["When target is not in yet" [self enterWhenNotPresent "will bring it in"] on: ProjectEntryNotification do: [:ex | ^ex projectToEnter enterAsActiveSubprojectWithin: self world]. project class == DiskProxy ifTrue: [self error: 'Could not find view']]. (owner isSystemWindow) ifTrue: [project setViewSize: self extent]. self showMouseState: 3. project enterAsActiveSubprojectWithin: self world! ! !ProjectViewMorph methodsFor: 'events' stamp: 'yo 7/2/2004 20:04'! showMenuForProjectView | menu selection | (menu _ CustomMenu new) add: 'enter this project' translated action: [^ self enter]; add: 'ENTER ACTIVE' translated action: [self setProperty: #wasOpenedAsSubproject toValue: true. ^ self enterAsActiveSubproject]; add: 'PUBLISH (also saves a local copy)' translated action: [^ project storeOnServerShowProgressOn: self forgetURL: false]; add: 'PUBLISH to a different server' translated action: [project forgetExistingURL. ^ project storeOnServerShowProgressOn: self forgetURL: true]; add: 'see if server version is more recent' translated action: [^ self checkForNewerVersionAndLoad]; addLine; add: 'expunge this project' translated action: [^ self expungeProject]. selection _ menu build startUpCenteredWithCaption: 'Project Named "\{1}"' translated withCRs. selection ifNil: [^ self]. selection value! ! !ProjectViewMorph methodsFor: 'events' stamp: 'kfr 10/9/2004 10:36'! showMouseState: anInteger | aMorph | (owner isSystemWindow) ifTrue: [aMorph := owner] ifFalse: [aMorph := self]. anInteger = 1 ifTrue: ["enter" aMorph addMouseActionIndicatorsWidth: 10 color: (Color blue alpha: 0.3)]. anInteger = 2 ifTrue: ["down" aMorph addMouseActionIndicatorsWidth: 15 color: (Color blue alpha: 0.7)]. anInteger = 3 ifTrue: ["leave" aMorph deleteAnyMouseActionIndicators]! ! !ProjectViewMorph methodsFor: 'rounding' stamp: 'gm 2/16/2003 20:34'! wantsRoundedCorners ^Preferences roundedWindowCorners and: [(owner isSystemWindow) not]! ! !ProjectViewMorph methodsFor: '*morphic-Postscript Canvases' stamp: 'RAA 4/19/2001 11:25'! fullDrawPostscriptOn: aCanvas | f | "handle the fact that we have the squished text within" f _ self imageForm. f offset: 0@0. aCanvas paintImage: f at: bounds origin. ! ! !ProjectViewMorph class methodsFor: 'class initialization' stamp: 'hg 8/3/2000 16:54'! initialize FileList registerFileReader: self! ! !ProjectViewMorph class methodsFor: 'fileIn/Out' stamp: 'nk 7/16/2003 15:55'! fileReaderServicesForFile: fullName suffix: suffix ^({ 'extseg'. 'project'. 'pr'. 'morph'. 'morphs'. 'sp'. '*' } includes: suffix) ifTrue: [ self services] ifFalse: [#()]! ! !ProjectViewMorph class methodsFor: 'fileIn/Out' stamp: 'sd 2/1/2002 22:01'! services ^ Array with: self serviceOpenProjectFromFile ! ! !ProjectViewMorph class methodsFor: 'initialize-release' stamp: 'SD 11/15/2001 22:22'! unload FileList unregisterFileReader: self ! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'sw 4/24/2001 12:00'! newMVCProject "Create an instance of me on a new MVC project (in a SystemWindow)." | proj window | proj _ Project new. window _ (SystemWindow labelled: proj name) model: proj. window addMorph: (self on: proj) frame: (0@0 corner: 1.0@1.0). ^ window ! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'ar 8/31/2004 20:53'! newProjectViewInAWindowFor: aProject "Return an instance of me on a new Morphic project (in a SystemWindow)." | window proj | proj := self on: aProject. window _ (SystemWindow labelled: aProject name) model: aProject. window addMorph: proj frame: (0@0 corner: 1.0@1.0). proj borderWidth: 0. ^ window ! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/2/2002 08:11'! openFromDirectory: aDirectory andFileName: aFileName Project canWeLoadAProjectNow ifFalse: [^ self]. ^ProjectLoading openFromDirectory: aDirectory andFileName: aFileName! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/2/2002 08:30'! openFromDirectoryAndFileName: anArray Project canWeLoadAProjectNow ifFalse: [^ self]. ^ProjectLoading openFromDirectory: anArray first andFileName: anArray second! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:19'! openFromFile: fileName self flag: #bob. "better not to use this one. nil directories are not nice. see #openFromDirectoryAndFileName: or #openFromDirectory:andFileName: instead" self halt. Project canWeLoadAProjectNow ifFalse: [^ self]. ^ProjectLoading openFromDirectory: nil andFileName: fileName! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:19'! openFromFileList: fullName self flag: #bob. "not sent??" self halt. ^self openFromFile: fullName! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'RAA 2/22/2002 06:12'! serviceOpenProjectFromFile "Answer a service for opening a .pr project file" ^ (SimpleServiceEntry provider: self label: 'load as project' selector: #openFromDirectoryAndFileName: description: 'open project from file' buttonLabel: 'load' ) argumentGetter: [ :fileList | fileList dirAndFileName]! ! !ProjectViewMorph class methodsFor: 'scripting' stamp: 'dgd 8/26/2004 12:11'! defaultNameStemForInstances ^ 'ProjectView'! ! !ProportionalLayout methodsFor: 'layout' stamp: 'ar 2/5/2002 20:05'! minExtentOf: aMorph in: newBounds "Return the minimal size aMorph's children would require given the new bounds" | min extent frame | min _ 0@0. aMorph submorphsDo:[:m| "Map the minimal size of the child through the layout frame. Note: This is done here and not in the child because its specific for proportional layouts. Perhaps we'll generalize this for table layouts but I'm not sure how and when." extent _ m minExtent. frame _ m layoutFrame. frame ifNotNil:[extent _ frame minExtentFrom: extent]. min _ min max: extent]. ^min! ! !ProtoObject methodsFor: 'system primitives' stamp: 'ajh 1/13/2002 17:02'! cannotInterpret: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector. Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose." "If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent." (self class lookupSelector: aMessage selector) == nil ifFalse: ["Simulated lookup succeeded -- resend the message." ^ aMessage sentTo: self]. "Could not recover by simulated lookup -- it's an error" Error signal: 'MethodDictionary fault'. "Try again in case an error handler fixed things" ^ aMessage sentTo: self! ! !ProtoObject methodsFor: 'system primitives' stamp: 'ajh 10/9/2001 17:20'! doesNotUnderstand: aMessage ^ MessageNotUnderstood new message: aMessage; receiver: self; signal! ! !ProtoObject methodsFor: 'initialize-release' stamp: 'md 11/18/2003 10:33'! initialize "Subclasses should redefine this method to perform initializations on instance creation"! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 with: arg3 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:20'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObject methodsFor: 'apply primitives' stamp: 'ajh 1/31/2003 22:21'! tryPrimitive: primIndex withArgs: argumentArray "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailToken! ! !ProtoObjectTest methodsFor: 'testing - testing' stamp: 'md 4/15/2003 21:30'! testFlag self shouldnt: [ProtoObject new flag: #hallo] raise: Error.! ! !ProtoObjectTest methodsFor: 'testing - testing' stamp: 'md 4/15/2003 21:29'! testIsNil self assert: (ProtoObject new isNil = false).! ! !ProtoObjectTest commentStamp: '' prior: 0! This is the unit test for the class ProtoObject. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !ProtocolBrowser methodsFor: 'accessing' stamp: 'sw 1/28/2001 21:01'! growable "Answer whether the receiver is subject to manual additions and deletions" ^ false! ! !ProtocolBrowser methodsFor: 'private' stamp: 'nk 8/18/2001 18:16'! initListFrom: selectorCollection highlighting: aClass "Make up the messageList with items from aClass in boldface." | defClass item | messageList := OrderedCollection new. selectorCollection do: [ :selector | defClass := aClass whichClassIncludesSelector: selector. item _ selector, ' (' , defClass name , ')'. defClass == aClass ifTrue: [item _ item asText allBold]. messageList add: ( MethodReference new setClass: defClass methodSymbol: selector stringVersion: item ) ]. selectedClass _ aClass.! ! !ProtocolBrowser methodsFor: 'private' stamp: 'RAA 5/28/2001 11:07'! setClassAndSelectorIn: csBlock "Decode strings of the form ( [class])" | i classAndSelString selString sel | sel _ self selection ifNil: [^ csBlock value: nil value: nil]. (sel isKindOf: MethodReference) ifTrue: [ sel setClassAndSelectorIn: csBlock ] ifFalse: [ selString _ sel asString. i _ selString indexOf: $(. "Rearrange to [class] , and use MessageSet" classAndSelString _ (selString copyFrom: i + 1 to: selString size - 1) , ' ' , (selString copyFrom: 1 to: i - 1) withoutTrailingBlanks. MessageSet parse: classAndSelString toClassAndSelector: csBlock. ]. ! ! !ProtocolBrowser methodsFor: 'class list' stamp: 'nk 4/10/2001 08:16'! selectedClassOrMetaClass ^selectedClass! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 3/7/2002 14:55'! logProgressToTranscript self progressObservers add: Transcript! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! response ^self protocolInstance lastResponse! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream ^stream! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream: aStream stream _ aStream! ! !ProtocolClient methodsFor: 'testing' stamp: 'mir 3/7/2002 14:33'! isConnected ^stream notNil and: [stream isConnected]! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! connectionInfo connectInfo ifNil: [connectInfo _ Dictionary new]. ^connectInfo! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:34'! defaultPortNumber ^self class defaultPortNumber! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 11/14/2002 18:29'! ensureConnection self isConnected ifTrue: [^self]. self stream ifNotNil: [self stream close]. self stream: (SocketStream openConnectionToHost: self host port: self port). self checkResponse. self login! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! host ^self connectionInfo at: #host! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! host: hostId ^self connectionInfo at: #host put: hostId! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse ^lastResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse: aString lastResponse _ aString. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:07'! logFlag ^self class logFlag! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! logProgress: aString self progressObservers do: [:each | each show: aString]. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:40'! openOnHost: hostIP port: portNumber self host: hostIP. self port: portNumber. self ensureConnection! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! password ^self connectionInfo at: #password! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! password: aString ^self connectionInfo at: #password put: aString! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pendingResponses pendingResponses ifNil: [pendingResponses := OrderedCollection new]. ^pendingResponses! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:55'! popResponse | pendingResponse | pendingResponse := self pendingResponses removeFirst. pendingResponses isEmpty ifTrue: [pendingResponses := nil]. ^pendingResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:57'! port ^self connectionInfo at: #port! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:38'! port: aPortNumber ^self connectionInfo at: #port put: aPortNumber! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 14:54'! progressObservers progressObservers ifNil: [progressObservers _ OrderedCollection new]. ^progressObservers! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pushResponse: aResponse self pendingResponses add: aResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! resetConnectionInfo connectInfo _ nil! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 11/11/2002 16:19'! user ^self connectionInfo at: #user ifAbsent: [nil]! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:39'! user: aString ^self connectionInfo at: #user put: aString! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:10'! close self stream ifNotNil: [ self stream close. stream _ nil]! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:11'! reopen self ensureConnection! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:52'! checkForPendingError "If data is waiting, check it to catch any error reports. In case the response is not an error, push it back." self stream isDataAvailable ifFalse: [^self]. self fetchNextResponse. self checkResponse: self lastResponse onError: [:response | (TelnetProtocolError protocolInstance: self) signal] onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. "if we get here, it wasn't an error" self pushResponse: self lastResponse! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/9/2003 18:47'! checkResponse "Get the response from the server and check for errors." self checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal] onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. ! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:51'! checkResponse: aResponse onError: errorBlock onWarning: warningBlock "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." self responseIsError ifTrue: [errorBlock value: aResponse]. self responseIsWarning ifTrue: [warningBlock value: aResponse]. ! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:54'! checkResponseOnError: errorBlock onWarning: warningBlock "Get the response from the server and check for errors. Invoke one of the blocks if an error or warning is encountered. See class comment for classification of error codes." self fetchPendingResponse. self checkResponse: self lastResponse onError: errorBlock onWarning: warningBlock! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/7/2002 13:16'! fetchNextResponse self lastResponse: self stream nextLine! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:50'! fetchPendingResponse ^pendingResponses ifNil: [self fetchNextResponse; lastResponse] ifNotNil: [self popResponse]! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/12/2003 18:10'! sendCommand: aString self stream sendCommand: aString. ! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/5/2002 14:31'! sendStreamContents: aStream self stream sendStreamContents: aStream! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsError self subclassResponsibility! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsWarning self subclassResponsibility! ! !ProtocolClient commentStamp: 'mir 5/12/2003 18:03' prior: 0! ProtocolClient is the abstract super class for a variety of network protocol clients. Is uses a stream rather than the direct network access so it could also work for stream on serial connections etc. Structure: stream stream presenting the connection to and from the server connectInfo infos required for opening a connection lastResponse remembers the last response from the server. progressObservers any object understanding #show: can be registered as a progress observer (login, transfer, etc)! !ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:59'! openOnHost: hostIP port: portNumber ^self new openOnHost: hostIP port: portNumber! ! !ProtocolClient class methodsFor: 'instance creation' stamp: 'gk 3/2/2004 11:10'! openOnHostNamed: hostName "If the hostname uses the colon syntax to express a certain portnumber we use that instead of the default port number." | i | i _ hostName indexOf: $:. i = 0 ifTrue: [ ^self openOnHostNamed: hostName port: self defaultPortNumber] ifFalse: [ | s p | s _ hostName truncateTo: i - 1. p _ (hostName copyFrom: i + 1 to: hostName size) asInteger. ^self openOnHostNamed: s port: p] ! ! !ProtocolClient class methodsFor: 'instance creation' stamp: 'mir 2/25/2002 15:58'! openOnHostNamed: hostName port: portNumber | serverIP | serverIP _ NetNameResolver addressForName: hostName timeout: 20. ^self openOnHost: serverIP port: portNumber ! ! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 16:00'! defaultPortNumber self subclassResponsibility! ! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'! logFlag self subclassResponsibility! ! !ProtocolClient class methodsFor: 'retrieval' stamp: 'mir 3/5/2002 16:21'! retrieveMIMEDocument: aURI self subclassResponsibility! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:17'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! protocolInstance ^protocolInstance! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! protocolInstance: aProtocolInstance protocolInstance _ aProtocolInstance! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 5/16/2003 11:18'! response ^self protocolInstance lastResponse! ! !ProtocolClientError commentStamp: 'mir 5/12/2003 18:05' prior: 0! Abstract super class for protocol clients protocolInstance reference to the protocol client throughing the exception. Exception handlers can access the client in order close, respond or whatever may be appropriate ! !ProtocolClientError class methodsFor: 'instance creation' stamp: 'mir 10/30/2000 16:15'! protocolInstance: aProtocolInstance ^self new protocolInstance: aProtocolInstance! ! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! prototype "Get a prototype" ^ prototype copy ! ! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! prototype: aPrototype "Set my prototype" prototype _ aPrototype copy ! ! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:57'! result "Perform the test the default number of times" ^ self resultFor: self class defaultRuns ! ! !PrototypeTester commentStamp: 'mjr 8/20/2003 13:09' prior: 0! I am a simple holder of a prototype object and hand out copies when requested.! !PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! defaultRuns "the default number of times to test" ^ 50! ! !PrototypeTester class methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 13:08'! with: aPrototype ^self new prototype:aPrototype! ! !PseudoClass methodsFor: 'class' stamp: 'BJP 4/23/2001 13:50'! comment | rStr | rStr := self organization commentRemoteStr. ^rStr isNil ifTrue:[self name,' has not been commented in this file'] ifFalse:[rStr string]! ! !PseudoClass methodsFor: 'class' stamp: 'ar 2/5/2004 15:18'! commentString ^self comment asString! ! !PseudoClass methodsFor: 'class' stamp: 'LC 10/8/2001 04:46'! definition | link linkText defText | ^definition ifNil: [defText _ Text fromString: 'There is no class definition for '. link _ TextLink new. linkText _ link analyze: self name with: 'Definition'. linkText _ Text string: (linkText ifNil: ['']) attribute: link. defText append: linkText; append: ' in this file'].! ! !PseudoClass methodsFor: 'class' stamp: 'nk 2/18/2004 18:30'! renameTo: aString self hasDefinition ifTrue:[ self isMeta ifTrue:[ self definition: (self definition copyReplaceAll: name,' class' with: aString, ' class'). ] ifFalse:[ self definition: (self definition copyReplaceAll:'ubclass: #',name with:'ubclass: #', aString)]]. name := aString. metaClass ifNotNil:[metaClass renameTo: aString].! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 4/29/2004 06:59'! allCallsOn ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! allSuperclasses ^ (self realClass ifNil: [ ^#() ]) allSuperclasses! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 3/9/2004 10:24'! instVarNames ^ #()! ! !PseudoClass methodsFor: 'accessing' stamp: 'NS 4/6/2004 15:46'! organization organization ifNil: [organization _ PseudoClassOrganizer defaultList: SortedCollection new]. "Making sure that subject is set correctly. It should not be necessary." organization setSubject: self. ^ organization! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! realClass ^Smalltalk at: self name asSymbol ifAbsent: []! ! !PseudoClass methodsFor: 'accessing' stamp: 'sd 6/27/2003 22:56'! theMetaClass ^ self metaclass! ! !PseudoClass methodsFor: 'private' stamp: 'nk 2/18/2004 18:33'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level ^ (self realClass ifNil: [ ^self ]) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! ! !PseudoClass methodsFor: 'private' stamp: 'ajh 1/21/2003 13:03'! parserClass ^ Compiler parserClass! ! !PseudoClass methodsFor: 'testing' stamp: 'nk 2/18/2004 18:30'! isMeta ^false! ! !PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'! fileOut | internalStream | internalStream _ WriteStream on: (String new: 1000). self fileOutOn: internalStream. self needsInitialize ifTrue:[ internalStream cr; nextChunkPut: self name,' initialize'. ]. FileStream writeSourceCodeFrom: internalStream baseName: self name isSt: true useHtml: false. ! ! !PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'! fileOutCategory: categoryName | internalStream | internalStream _ WriteStream on: (String new: 1000). self fileOutMethods: (self organization listAtCategoryNamed: categoryName) on: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: (self name, '-', categoryName) isSt: true useHtml: false. ! ! !PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'hg 9/6/2000 12:45'! fileOutDefinitionOn: aStream self hasDefinition ifFalse:[^self]. aStream nextChunkPut: self definition; cr. self hasComment ifTrue: [aStream cr. self organization commentRemoteStr fileOutOn: aStream]! ! !PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'yo 7/5/2004 20:21'! fileOutMethod: selector | internalStream | internalStream _ WriteStream on: (String new: 1000). self fileOutMethods: (Array with: selector) on: internalStream. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true useHtml: false. ! ! !PseudoClass methodsFor: 'fileIn/fileOut' stamp: 'ar 2/7/2004 01:04'! fileOutMethods: aCollection on: aStream "FileOut all methods with selectors taken from aCollection" | cat categories | categories := Dictionary new. aCollection do:[:sel| cat := self organization categoryOfElement: sel. cat = self removedCategoryName ifFalse:[ (categories includesKey: cat) ifFalse:[categories at: cat put: Set new]. (categories at: cat) add: sel]. ]. categories associationsDo:[:assoc| cat := assoc key. assoc value do:[:sel| aStream cr. (self sourceCode at: sel) fileOutOn: aStream. ]. ].! ! !PseudoClass methodsFor: 'methods' stamp: 'sw 6/10/2003 17:31'! stampAt: selector "Answer the authoring time-stamp of the change" | code | ^ ((code _ self sourceCode at: selector) isKindOf: ChangeRecord) ifTrue: [code stamp] ifFalse: [code string]! ! !PseudoClass methodsFor: 'printing' stamp: 'ar 2/5/2004 16:04'! printOn: aStream super printOn: aStream. aStream nextPut:$(; print: name; nextPut:$)! ! !PseudoClass methodsFor: 'testing method dictionary' stamp: 'ar 5/17/2003 14:06'! bindingOf: varName self exists ifTrue:[ (self realClass bindingOf: varName) ifNotNilDo:[:binding| ^binding]. ]. ^Smalltalk bindingOf: varName asSymbol! ! !PseudoClass commentStamp: '' prior: 0! I provide an inert model of a Class, used by FileContentsBrowser to manipulate filedout code. Instead of a method dictionary or selectors onto CompiledMethods, I have a dictionary ("source") of selectors onto ChangeRecords, which were, in the case of FileContentsBrowser, parsed from a source or change set file.! !PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! classComment "Answer the comment associated with the object that refers to the receiver." classComment == nil ifTrue: [^'']. ^classComment! ! !PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! classComment: aChangeRecord classComment := aChangeRecord! ! !PseudoClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 12:27'! setDefaultList: aCollection super setDefaultList: aCollection. self classComment: nil.! ! !PseudoMetaclass methodsFor: 'accessing' stamp: 'FBS 3/4/2004 14:17'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self realClass theNonMetaClass! ! !PseudoMetaclass methodsFor: 'testing' stamp: 'nk 2/18/2004 18:30'! isMeta ^true! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 12:08'! canAssign ^ setterBlock notNil! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'! getter: block getterBlock _ block! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:15'! name ^ name! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:00'! name: string name _ string! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 9/12/2002 03:01'! setter: block setterBlock _ block! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 14:02'! value ^ getterBlock value! ! !PseudoPoolVariable methodsFor: 'as yet unclassified' stamp: 'ajh 7/2/2004 13:58'! value: obj setterBlock value: obj! ! !PseudoPoolVariable commentStamp: '' prior: 0! The values of pool and global variables (traditionally Associations) are fetched by sending #poolValue and set by sending #setInPool: which send #poolValue:. These sends are automatically added in by the Compiler (see PoolVarNode {code generation}). So any object can act like a pool variable. This class allows getter and setter blocks for poolValue and poolValue:.! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:30'! setHeight: aNumber "Set the receiver's height" self region: (origin extent: (self width @ aNumber))! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 17:54'! setLeft: aNumber "Move the receiver so that its left edge is given by aNumber. An example of a setter to go with #left" self region: ((aNumber @ origin y) extent: self extent)! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:19'! setRight: aNumber "Move the receiver so that its right edge is given by aNumber. An example of a setter to go with #right" self region: ((origin x + (aNumber - self right) @ origin y) extent: self extent)! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:26'! setWidth: aNumber "Set the receiver's width" self region: (origin extent: (aNumber @ self height))! ! !Quadrangle methodsFor: 'vocabulary' stamp: 'sw 5/4/2001 16:45'! vocabularyDemanded "Answer the vocabulary that the receiver really would like to use in a Viewer" ^ Vocabulary quadVocabulary! ! !Quadrangle class methodsFor: 'instance creation' stamp: 'sw 5/4/2001 17:12'! exampleInViewer "Create a sample Quadrangle and open a Viewer on it" (self region: (100@100 extent: 100@50) borderWidth: (1 + (6 atRandom)) borderColor: Color black insideColor: (Color perform: #(green red blue yellow) atRandom)) beViewed "Quadrangle exampleInViewer"! ! !QueueSound commentStamp: 'efc 1/2/2003 00:30' prior: 0! I am a queue for sound - give me a bunch of sounds to play and I will play them one at a time in the order that they are received. Example: "Here is a simple example which plays two sounds three times." | clink warble queue | clink _ SampledSound soundNamed: 'clink'. warble _ SampledSound soundNamed: 'warble'. queue _ QueueSound new. 3 timesRepeat:[ queue add: clink; add: warble ]. queue play. Structure: startTime Integer -- if present, start playing when startTime <= Time millisecondClockValue (schedule the sound to play later) sounds SharedQueue -- the synchronized list of sounds. currentSound AbstractSound -- the currently active sound done Boolean -- am I done playing ? Other: You may want to keep track of the queue's position so that you can feed it at an appropriate rate. To do this in an event driven way, modify or subclass nextSound to notify you when appropriate. You could also poll by checking currentSound, but this is not recommended for most applications. ! !RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'ar 3/5/2001 12:12'! upToEnd "Must override to get class right." | newArray | newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [String]) new: self size - self position. ^ self nextInto: newArray! ! !RWBinaryOrTextStream methodsFor: 'writing' stamp: 'ar 8/12/2003 16:54'! next: anInteger putAll: aCollection startingAt: startIndex ^super next: anInteger putAll: aCollection asString startingAt: startIndex! ! !RWBinaryOrTextStream methodsFor: 'writing' stamp: 'ar 8/12/2003 16:54'! nextPutAll: aCollection ^super nextPutAll: aCollection asString! ! !RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:34'! bottomRightColor ^width = 1 ifTrue: [color twiceDarker] ifFalse: [color darker]! ! !RaisedBorder methodsFor: 'accessing' stamp: 'ar 11/26/2001 15:23'! colorsAtCorners | c c14 c23 | c _ self color. c14 _ c lighter. c23 _ c darker. ^Array with: c14 with: c23 with: c23 with: c14! ! !RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#raised! ! !RaisedBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:34'! topLeftColor ^width = 1 ifTrue: [color twiceLighter] ifFalse: [color lighter]! ! !RaisedBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph raisedColor].! ! !RaisedBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0! see BorderedMorph! !Random methodsFor: 'accessing' stamp: 'dns 8/26/2001 18:43'! nextInt: anInteger "Answer a random integer in the interval [1, anInteger]." anInteger strictlyPositive ifFalse: [ self error: 'Range must be positive' ]. ^ (self next * anInteger) truncated + 1! ! !Random commentStamp: 'md 4/26/2003 16:32' prior: 0! This Random Number Generator graciously contributed by David N. Smith. It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic. If you just want a quick random integer, use: 10 atRandom Every integer interval can give a random number: (6 to: 12) atRandom SequenceableCollections can give randomly selected elements: 'pick one of these letters randomly' atRandom SequenceableCollections also respond to shuffled, as in: ($A to: $Z) shuffled The correct way to use class Random is to store one in an instance or class variable: myGenerator _ Random new. Then use it every time you need another number between 0.0 and 1.0 (excluding) myGenerator next You can also generate a positive integer myGenerator nextInt: 10! !Random class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 21:51'! seed: anInteger ^self new seed: anInteger! ! !RandomNumberTile methodsFor: 'event handling' stamp: 'RAA 7/31/2001 12:02'! handlesMouseDown: evt | aPoint | self inPartsBin ifTrue: [^false]. aPoint _ evt cursorPoint. "This might actually be a suitable test for the superclass, but I'll do it here to minimize the downside" {upArrow. downArrow. suffixArrow. retractArrow} do: [ :each | (each notNil and: [each bounds containsPoint: aPoint]) ifTrue: [ ^true ] ]. ^false "super handlesMouseDown: evt"! ! !RandomNumberTile methodsFor: 'initialization' stamp: 'dgd 9/20/2003 19:11'! initialize "Initialize the receiver fully, including adding all its relevant submorphs" | m1 m2 | super initialize. self vResizing: #shrinkWrap. self typeColor: (ScriptingSystem colorForType: #Number). self addArrows. m1 _ StringMorph contents: 'random' translated font: ScriptingSystem fontForTiles. self addMorph: m1. m2 _ UpdatingStringMorph contents: '180' font: ScriptingSystem fontForTiles. m2 target: self; getSelector: #literal; putSelector: #literal:. m2 position: m1 topRight. self addMorphBack: m2. literal _ 180. self updateLiteralLabel. self makeAllTilesGreen! ! !RandomNumberTile methodsFor: 'initialization' stamp: 'yo 7/2/2004 20:59'! updateWordingToMatchVocabulary | stringMorph | stringMorph _ submorphs detect: [:morph | morph class == StringMorph] ifNone: [^ self]. stringMorph contents: 'random' translated. ! ! !RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:50'! initialize self registerInFlapsRegistry. ! ! !RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:51'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(RandomNumberTile new 'Random' 'A random-number tile for use with tile scripting') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(RandomNumberTile new 'Random' 'A tile that will produce a random number in a given range') forFlapNamed: 'Scripting'.]! ! !RandomNumberTile class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !RandomTest methodsFor: 'setup' stamp: 'md 4/2/2003 12:32'! setUp gen := Random seed: 112629.! ! !RandomTest methodsFor: 'testing - accessing' stamp: 'md 4/2/2003 12:50'! testNext 10000 timesRepeat: [ | next | next := gen next. self assert: (next >= 0). self assert: (next < 1). ].! ! !RcsDiff methodsFor: 'accessing' stamp: 'gh 11/22/2001 23:44'! commandLines: aString commandLines _ aString! ! !RcsDiff methodsFor: 'applying' stamp: 'gh 11/23/2001 11:35'! applyTo: aString "Apply me to given String and return the patched String." | space commandStream originalStream nextCommand nextLine lineCount currentLine | space _ Character space. commandStream _ ReadStream on: commandLines. originalStream _ ReadStream on: aString. currentLine _ 1. ^String streamContents: [:stream | [nextCommand _ commandStream next. nextCommand isNil] whileFalse: [ nextLine _ (commandStream upTo: space) asNumber. lineCount _ commandStream nextLine asNumber. [currentLine = nextLine] whileFalse: [stream nextPutAll: originalStream nextLine; cr. currentLine _ currentLine + 1]. nextCommand = $d ifTrue:[ lineCount timesRepeat: [originalStream nextLine. currentLine _ currentLine + 1]] ifFalse:[ nextCommand = $a ifTrue:[ stream nextPutAll: originalStream nextLine; cr. currentLine _ currentLine + 1. lineCount timesRepeat: [ stream nextPutAll: commandStream nextLine; cr]]]]. stream nextPutAll: originalStream upToEnd]! ! !RcsDiff class methodsFor: 'instance creation' stamp: 'gh 11/22/2001 23:44'! lines: aString "Create a new RcsDiff file." ^(self new) commandLines: aString; yourself! ! !ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ajh 9/12/2002 12:06'! canAssign ^ false! ! !ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ar 8/14/2001 23:09'! value ^value! ! !ReadOnlyVariableBinding methodsFor: 'accessing' stamp: 'ar 8/17/2001 18:03'! value: aValue (AttemptToWriteReadOnlyGlobal signal: 'Cannot store into read-only bindings') == true ifTrue:[ value _ aValue. ].! ! !ReadOnlyVariableBinding methodsFor: 'testing' stamp: 'ar 8/14/2001 23:08'! isSpecialWriteBinding "Return true if this variable binding is write protected, e.g., should not be accessed primitively but rather by sending #value: messages" ^true! ! !ReadOnlyVariableBinding methodsFor: 'private' stamp: 'ar 8/14/2001 23:11'! privateSetKey: aKey value: aValue key _ aKey. value _ aValue! ! !ReadOnlyVariableBinding class methodsFor: 'instance creation' stamp: 'ar 8/14/2001 23:11'! key: key value: aValue ^self new privateSetKey: key value: aValue! ! !ReadStream methodsFor: 'accessing'! next "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !ReadStream methodsFor: 'accessing' stamp: 'ajh 9/5/2002 22:11'! readStream "polymorphic with SequenceableCollection. Return self" ^ self! ! !ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:00'! localName ^'ReadStream'! ! !ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:01'! openReadOnly! ! !ReadStream methodsFor: 'file stream compatibility' stamp: 'nk 12/13/2002 12:00'! readOnly! ! !ReadStream methodsFor: '*packageinfo-base' stamp: 'ab 5/24/2003 14:28'! untilEnd: aBlock displayingProgress: aString aString displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. aBlock value]].! ! !ReadStreamTest methodsFor: 'as yet unclassified' stamp: 'bp 10/29/2004 05:57'! streamOn: collection upToAll: subcollection ^(ReadStream on: collection) upToAll: subcollection! ! !ReadStreamTest methodsFor: 'as yet unclassified' stamp: 'bp 10/29/2004 06:01'! streamOn: collection upToAll: subcollection1 upToAll: subcollection2 ^(ReadStream on: collection) upToAll: subcollection1; upToAll: subcollection2! ! !ReadStreamTest methodsFor: 'as yet unclassified' stamp: 'tlk 12/5/2004 14:34'! testPositionOfSubCollection self assert: ('xyz' readStream positionOfSubCollection: 'q' ) = 0. self assert: ('xyz' readStream positionOfSubCollection: 'x' ) = 1. self assert: ('xyz' readStream positionOfSubCollection: 'y' ) = 2. self assert: ('xyz' readStream positionOfSubCollection: 'z' ) = 3.! ! !ReadStreamTest methodsFor: 'as yet unclassified' stamp: 'bp 10/29/2004 06:16'! testUpToAll self assert: (self streamOn: 'abcdefgh' upToAll: 'cd') = 'ab'. self assert: (self streamOn: 'abcdefgh' upToAll: 'cd' upToAll: 'gh') = 'ef'. self assert: (self streamOn: '' upToAll: '') = ''. self assert: (self streamOn: 'a' upToAll: '') = ''. self assert: (self streamOn: 'a' upToAll: 'a') = ''. self assert: (self streamOn: 'a' upToAll: 'b') = 'a'. self assert: (self streamOn: 'ab' upToAll: '') = ''. self assert: (self streamOn: 'ab' upToAll: 'a') = ''. self assert: (self streamOn: 'ab' upToAll: 'b') = 'a'. self assert: (self streamOn: 'ab' upToAll: 'c') = 'ab'. self assert: (self streamOn: 'ab' upToAll: 'ab') = ''. self assert: (self streamOn: 'abc' upToAll: '') = ''. self assert: (self streamOn: 'abc' upToAll: 'a') = ''. self assert: (self streamOn: 'abc' upToAll: 'b') = 'a'. self assert: (self streamOn: 'abc' upToAll: 'c') = 'ab'. self assert: (self streamOn: 'abc' upToAll: 'd') = 'abc'. self assert: (self streamOn: 'abc' upToAll: 'ab') = ''. self assert: (self streamOn: 'abc' upToAll: 'bc') = 'a'. self assert: (self streamOn: 'abc' upToAll: 'cd') = 'abc'. ! ! !ReadStreamTest commentStamp: 'tlk 12/5/2004 14:36' prior: 0! I am an SUnit test for ReadStream. I have no test fixtures.! !ReadWriteStream methodsFor: 'accessing'! next "Primitive. Return the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." "treat me as a FIFO" position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !ReadWriteStream methodsFor: 'accessing' stamp: 'ar 8/5/2003 02:23'! next: anInteger "Answer the next anInteger elements of my collection. overriden for efficiency" | ans endPosition | readLimit := readLimit max: position. endPosition _ position + anInteger min: readLimit. ans _ collection copyFrom: position+1 to: endPosition. position _ endPosition. ^ans ! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'RAA 4/6/2001 18:32'! fileOutChangeSet: aChangeSetOrNil andObject: theObject "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically." "An experimental version to fileout a changeSet first so that a project can contain its own classes" self setFileTypeToObject. "Type and Creator not to be text, so can attach correctly to an email msg" self header; timeStamp. aChangeSetOrNil ifNotNil: [ aChangeSetOrNil fileOutPreambleOn: self. aChangeSetOrNil fileOutOn: self. aChangeSetOrNil fileOutPostscriptOn: self. ]. self trailer. "Does nothing for normal files. HTML streams will have trouble with object data" "Append the object's raw data" (SmartRefStream on: self) nextPut: theObject; "and all subobjects" close. "also closes me" ! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'sd 5/23/2003 14:41'! fileOutChanges "Append to the receiver a description of all class changes." Cursor write showWhile: [self header; timeStamp. ChangeSet current fileOutOn: self. self trailer; close]! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'yo 8/16/2004 13:45'! fileOutClass: extraClass andObject: theObject "Write a file that has both the source code for the named class and an object as bits. Any instance-specific object will get its class written automatically." | class srefStream | self setFileTypeToObject. "Type and Creator not to be text, so can attach correctly to an email msg" self text. self header; timeStamp. extraClass ifNotNil: [ class _ extraClass. "A specific class the user wants written" class sharedPools size > 0 ifTrue: [class shouldFileOutPools ifTrue: [class fileOutSharedPoolsOn: self]]. class fileOutOn: self moveSource: false toFile: 0]. self trailer. "Does nothing for normal files. HTML streams will have trouble with object data" self binary. "Append the object's raw data" srefStream _ SmartRefStream on: self. srefStream nextPut: theObject. "and all subobjects" srefStream close. "also closes me" ! ! !ReadWriteStream methodsFor: 'converting' stamp: 'yo 7/16/2003 14:59'! asUnZippedStream | isGZip outputStream first strm archive which | "Decompress this file if needed, and return a stream. No file is written. File extension may be .gz or anything else. Also works on archives (.zip, .gZip)." strm _ self binary. strm isZipArchive ifTrue: [ archive _ ZipArchive new readFrom: strm. which _ archive members detect: [:any | any fileName asLowercase endsWith: '.ttf'] ifNone: [nil]. which ifNil: [archive close. ^ self error: 'Can''t find .ttf file in archive']. strm _ which contentStream. archive close]. first _ strm next. isGZip _ (strm next * 256 + first) = (GZipConstants gzipMagic). strm skip: -2. isGZip ifTrue: [outputStream _ (MultiByteBinaryOrTextStream with: (GZipReadStream on: strm) upToEnd) reset. strm close] ifFalse: [outputStream _ strm]. ^ outputStream! ! !ReadWriteStream methodsFor: 'converting' stamp: 'ajh 9/14/2002 20:37'! readStream "polymorphic with SequenceableCollection. Return self" ^ self! ! !ReadWriteStream methodsFor: 'testing' stamp: 'tk 11/29/2001 12:47'! = other (self class == ReadWriteStream and: [other class == ReadWriteStream]) ifFalse: [ ^ super = other]. "does an identity test. Don't read contents of FileStream" ^ self position = other position and: [self contents = other contents]! ! !ReadWriteStream methodsFor: 'testing' stamp: 'tk 12/2/2001 17:13'! hash self class == ReadWriteStream ifFalse: [^ super hash]. ^ (self position + readLimit + 53) hash! ! !ReadWriteStream methodsFor: 'testing' stamp: 'nk 8/21/2004 15:47'! isZipArchive "Determine if this appears to be a valid Zip archive" | sig | self binary. sig _ self next: 4. self position: self position - 4. "rewind" ^ZipArchive validSignatures includes: sig! ! !ReadWriteStream methodsFor: '*packageinfo' stamp: 'ab 10/16/2002 15:56'! untilEnd: aBlock displayingProgress: aString aString displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. aBlock value]].! ! !ReadWriteStreamTest methodsFor: 'testing' stamp: 'md 10/22/2003 12:47'! testConstructionUsingWith "Use the with: constructor." | aStream | aStream _ ReadWriteStream with: #(1 2). self assert: (aStream contents = #(1 2)) description: 'Ensure correct initialization.'! ! !ReadWriteStreamTest methodsFor: 'testing' stamp: 'md 10/22/2003 12:54'! testNew self should: [ReadWriteStream new] raise: Error.! ! !ReadWriteStreamTest commentStamp: '' prior: 0! This is the unit test for the class ReadWriteStream. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 11/20/2001 00:16'! assignCollapseFrameFor: aSSView "Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames." | grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top | grid _ 8. verticalBorderDistance _ 8. aSSView isMorph ifTrue: [otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | w ~= aSSView]) collect: [:w | w collapsedFrame] thenSelect: [:rect | rect notNil]. viewBox _ self reduceByFlaps: aSSView world viewBox] ifFalse: [otherFrames _ ScheduledControllers scheduledWindowControllers collect: [:aController | aController view ~= aSSView ifTrue: [aController view collapsedFrame]] thenSelect: [:rect | rect notNil]. viewBox _ Display boundingBox]. collapsedFrame _ aSSView collapsedFrame. extent _ collapsedFrame notNil ifTrue: [collapsedFrame extent] ifFalse: [aSSView isMorph ifTrue: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)] ifFalse: [(aSSView labelText extent x + 70) @ aSSView labelHeight min: aSSView labelDisplayBox extent]]. collapsedFrame notNil ifTrue: [(otherFrames anySatisfy: [:f | collapsedFrame intersects: f]) ifFalse: ["non overlapping" ^ collapsedFrame]]. top _ viewBox top + verticalBorderDistance. [topLeft _ viewBox left @ top. newFrame _ topLeft extent: extent. newFrame bottom <= (viewBox height - verticalBorderDistance)] whileTrue: [(otherFrames anySatisfy: [:w | newFrame intersects: w]) ifFalse: ["no overlap" ^ newFrame]. top _ top + grid]. "If all else fails... (really to many wins here)" ^ 0 @ 0 extent: extent! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 11/20/2001 00:17'! assignCollapsePointFor: aSSView "Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames." | grid otherFrames y free topLeft viewBox | grid _ 24. "should be mult of 8, since manual move is gridded by 8" aSSView isMorph ifTrue: [otherFrames _ (SystemWindow windowsIn: aSSView world satisfying: [:w | true]) collect: [:w | w collapsedFrame] thenSelect: [:rect | rect notNil]. viewBox _ self reduceByFlaps: aSSView world viewBox] ifFalse: [otherFrames _ ScheduledControllers scheduledWindowControllers collect: [:aController | aController view collapsedFrame] thenSelect: [:rect | rect notNil]. viewBox _ Display boundingBox]. y _ viewBox top. [(y _ y + grid) <= (viewBox height - grid)] whileTrue: [topLeft _ viewBox left@y. free _ true. otherFrames do: [:w | free _ free & (topLeft ~= w topLeft)]. free ifTrue: [^ topLeft]]. "If all else fails..." ^ 0 @ 0! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'nk 7/5/2003 08:32'! initialFrameFor: aView initialExtent: initialExtent world: aWorld "Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen." | allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames | Preferences reverseWindowStagger ifTrue: [^ self strictlyStaggeredInitialFrameFor: aView initialExtent: initialExtent world: aWorld]. allowedArea _ self maximumUsableAreaInWorld: aWorld. screenRight _ allowedArea right. screenBottom _ allowedArea bottom. otherFrames _ Smalltalk isMorphic ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not]) collect: [:w | w bounds]] ifFalse: [ScheduledControllers scheduledWindowControllers select: [:aController | aController view ~~ nil] thenCollect: [:aController | aController view isCollapsed ifTrue: [aController view expandedFrame] ifFalse: [aController view displayBox]]]. allOrigins _ otherFrames collect: [:f | f origin]. (self standardPositionsInWorld: aWorld) do: "First see if one of the standard positions is free" [:aPosition | (allOrigins includes: aPosition) ifFalse: [^ (aPosition extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]]. staggerOrigin _ (self standardPositionsInWorld: aWorld) first. "Fallback: try offsetting from top left" putativeOrigin _ staggerOrigin. [putativeOrigin _ putativeOrigin + StaggerOffset. putativeFrame _ putativeOrigin extent: initialExtent. (putativeFrame bottom < screenBottom) and: [putativeFrame right < screenRight]] whileTrue: [(allOrigins includes: putativeOrigin) ifFalse: [^ (putativeOrigin extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea]]. ^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent) translatedAndSquishedToBeWithin: allowedArea! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'ar 3/17/2001 23:43'! maximumUsableArea | allowedArea | allowedArea _ Display usableArea. Smalltalk isMorphic ifTrue: [ allowedArea _ allowedArea intersect: ActiveWorld viewBox ]. ^allowedArea ! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'dgd 8/31/2003 19:52'! reduceByFlaps: aScreenRect "Return a rectangle that won't interfere with default shared flaps" Flaps sharedFlapsAllowed ifFalse: [^ aScreenRect copy]. (Flaps globalFlapTabsIfAny allSatisfy: [:ft | ft flapID = 'Painting' translated or: [ft edgeToAdhereTo == #bottom]]) ifTrue: [^ aScreenRect withHeight: aScreenRect height - 18] ifFalse: [^ aScreenRect insetBy: 18]! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'nk 7/5/2003 08:32'! strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent world: aWorld "This method implements a staggered window placement policy that I (di) like. Basically it provides for up to 4 windows, staggered from each of the 4 corners. The windows are staggered so that there will always be a corner visible." | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | allowedArea _(self maximumUsableAreaInWorld: aWorld) insetBy: (self scrollBarSetback @ self screenTopSetback extent: 0@0). (Smalltalk isMorphic and: [Flaps sharedFlapsAllowed]) ifTrue: [allowedArea _ self reduceByFlaps: allowedArea]. "Number to be staggered at each corner (less on small screens)" maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. "Amount by which to stagger (less on small screens)" grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. initialFrame _ 0@0 extent: ((initialExtent "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) min: 600@400")). otherFrames _ Smalltalk isMorphic ifTrue: [(SystemWindow windowsIn: aWorld satisfying: [:w | w isCollapsed not]) collect: [:w | w bounds]] ifFalse: [ScheduledControllers scheduledWindowControllers select: [:aController | aController view ~~ nil] thenCollect: [:aController | aController view isCollapsed ifTrue: [aController view expandedFrame] ifFalse: [aController view displayBox]]]. 0 to: maxLevel do: [:level | 1 to: 4 do: [:ci | cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: ci. corner _ allowedArea perform: cornerSel. "The extra grid//2 in delta helps to keep title tabs distinct" delta _ (maxLevel-level*grid+(grid//2)) @ (level*grid). 1 to: ci-1 do: [:i | delta _ delta rotateBy: #right centerAt: 0@0]. "slow way" putativeCorner _ corner + delta. free _ true. otherFrames do: [:w | free _ free & ((w perform: cornerSel) ~= putativeCorner)]. free ifTrue: [^ (initialFrame align: (initialFrame perform: cornerSel) with: putativeCorner) translatedAndSquishedToBeWithin: allowedArea]]]. "If all else fails..." ^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent) translatedAndSquishedToBeWithin: allowedArea! ! !RecategorizedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 19:51'! isRecategorized ^true! ! !RecategorizedEvent methodsFor: 'printing' stamp: 'rw 7/2/2003 09:12'! printEventKindOn: aStream aStream nextPutAll: 'Recategorized'! ! !RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'! oldCategory ^oldCategory! ! !RecategorizedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 20:08'! oldCategory: aCategoryName oldCategory := aCategoryName! ! !RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! changeKind ^#Recategorized! ! !RecategorizedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 11:20'! supportedKinds ^Array with: self classKind with: self methodKind! ! !RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/9/2003 14:21'! class: aClass category: cat oldCategory: oldName ^(self class: aClass category: cat) oldCategory: oldName! ! !RecategorizedEvent class methodsFor: 'instance creation' stamp: 'rw 7/31/2003 16:35'! method: aMethod protocol: prot class: aClass oldProtocol: oldName ^(self method: aMethod protocol: prot class: aClass) oldCategory: oldName! ! !RecentMessageSet methodsFor: 'update' stamp: 'RAA 5/29/2001 10:19'! reformulateList | myList | "Reformulate the receiver's list. Exclude methods now deleted" myList _ Utilities recentMethodSubmissions reversed select: [ :each | each isValid]. self initializeMessageList: myList. self messageListIndex: (messageList size min: 1). "0 or 1" self changed: #messageList. self changed: #messageListIndex! ! !RecentMessageSet methodsFor: 'update' stamp: 'RAA 5/29/2001 10:42'! updateListsAndCodeIn: aWindow | recentFromUtilities | "RAA 20 june 2000 - a recent change to how messages were displayed in the list caused them not to match what was stored in Utilities. This caused the recent submissions to be continuously updated. The hack below fixed that problem" self flag: #mref. "in second pass, use simpler test" self canDiscardEdits ifFalse: [^ self]. recentFromUtilities _ Utilities mostRecentlySubmittedMessage,' '. (messageList first asStringOrText asString beginsWith: recentFromUtilities) ifFalse: [self reformulateList] ifTrue: [self updateCodePaneIfNeeded]! ! !RecentMessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 23:20'! addExtraShiftedItemsTo: aMenu "The shifted selector-list menu is being built. Overridden here to defeat the presence of the items that add or change order, since RecentMessageSet defines methods & order explicitly based on external criteria" aMenu add: 'set size of recent history...' action: #setRecentHistorySize! ! !RecentMessageSet methodsFor: 'message list' stamp: 'sw 7/28/2002 23:50'! setRecentHistorySize "Let the user specify the recent history size" | aReply aNumber | aReply _ FillInTheBlank request: 'How many recent methods should be maintained?' initialAnswer: Utilities numberOfRecentSubmissionsToStore asString. aReply isEmptyOrNil ifFalse: [aNumber _ aReply asNumber rounded. (aNumber > 1 and: [aNumber <= 1000]) ifTrue: [Utilities numberOfRecentSubmissionsToStore: aNumber. self inform: 'Okay, ', aNumber asString, ' is the new size of the recent method history'] ifFalse: [self inform: 'Sorry, must be a number between 2 & 1000']] ! ! !RecentMessageSet methodsFor: 'message functions' stamp: 'sw 9/26/2002 17:59'! messageListMenu: aMenu shifted: shifted "Answer the message-list menu" shifted ifTrue: [^ self shiftedMessageListMenu: aMenu]. aMenu addList:#( ('what to show...' offerWhatToShowMenu) - ('browse full (b)' browseMethodFull) ('browse hierarchy (h)' classHierarchy) ('browse method (O)' openSingleMessageBrowser) ('browse protocol (p)' browseFullProtocol) - ('fileOut (o)' fileOutMessage) ('printOut' printOutMessage) ('copy selector (c)' copySelector) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) ('remove from RecentSubmissions' removeFromRecentSubmissions) - ('more...' shiftedYellowButtonActivity)). ^ aMenu! ! !RecentMessageSet methodsFor: 'message functions' stamp: 'sw 9/26/2002 18:09'! removeFromRecentSubmissions "Remove the currently-selected method from the RecentSubmissions list" | aClass methodSym | ((aClass _ self selectedClassOrMetaClass) notNil and: [(methodSym _ self selectedMessageName) notNil]) ifTrue: [Utilities purgeFromRecentSubmissions: (MethodReference new setStandardClass: aClass methodSymbol: methodSym). self reformulateList]! ! !RecentMessageSet commentStamp: 'sw 8/1/2002 17:40' prior: 0! RecentMessageSet is a message set that shows the most recently-submitted methods, in chronological order.! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'! makeSoundMorph | m | recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. m _ SoundEventMorph new sound: recorder recordedSound. self world firstHand attachMorph: m. ! ! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 3/3/2004 19:49'! makeTile "Make a tile representing my sound. Get a sound-name from the user by which the sound is to be known." | newStyleTile sndName tile | recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. newStyleTile _ true. newStyleTile ifTrue: [sndName _ FillInTheBlank request: 'Please name your new sound' translated initialAnswer: 'sound' translated. sndName isEmpty ifTrue: [^ self]. sndName _ SampledSound unusedSoundNameLike: sndName. SampledSound addLibrarySoundNamed: sndName samples: recorder condensedSamples samplingRate: recorder samplingRate. tile _ SoundTile new literal: sndName] ifFalse: [tile _ InterimSoundMorph new sound: (SampledSound samples: recorder condensedSamples samplingRate: recorder samplingRate)]. tile bounds: tile fullBounds. tile openInHand! ! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'! playback "The user hit the playback button" recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. recorder playback. ! ! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'! show "Show my samples in a WaveEditor." | ed w | recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. ed _ WaveEditor new. ed data: recorder condensedSamples. ed samplingRate: recorder samplingRate. w _ self world. w activeHand ifNil: [w addMorph: ed] ifNotNil: [w activeHand attachMorph: ed]. ! ! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'sw 6/10/2003 12:59'! trim "Show my samples in a GraphMorph." recorder verifyExistenceOfRecordedSound ifFalse: [^ self]. recorder pause. recorder trim: 1400 normalizedVolume: 80.0. ! ! !RecordingControlsMorph methodsFor: 'initialization' stamp: 'dgd 9/19/2003 12:21'! addButtonRows | r | r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: (self buttonName: 'Morph' translated action: #makeSoundMorph). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Tile' translated action: #makeTile). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Trim' translated action: #trim). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Show' translated action: #show). self addMorphBack: r. r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: (self buttonName: 'Record' translated action: #record). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Stop' translated action: #stop). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Play' translated action: #playback). r addMorphBack: self makeStatusLight. self addMorphBack: r. ! ! !RecordingControlsMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 18:18'! descriptionForPartsBin ^ self partName: 'SoundRecorder' categories: #('Multimedia') documentation: 'A device for making sound recordings.'! ! !RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:53'! initialize self registerInFlapsRegistry. ! ! !RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:54'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(RecordingControlsMorph authoringPrototype 'Sound' 'A device for making sound recordings.') forFlapNamed: 'Widgets'.]! ! !RecordingControlsMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !Rectangle methodsFor: 'accessing' stamp: 'di 11/17/2001 14:01'! area "Answer the receiver's area, the product of width and height." | w | (w _ self width) <= 0 ifTrue: [^ 0]. ^ w * self height max: 0! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'ar 1/5/2002 18:04'! allAreasOutsideList: aCollection do: aBlock "Enumerate aBlock with all areas of the receiver not overlapping any rectangle in the given collection" ^self allAreasOutsideList: aCollection startingAt: 1 do: aBlock! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'ar 1/5/2002 18:03'! allAreasOutsideList: aCollection startingAt: startIndex do: aBlock "Enumerate aBlock with all areas of the receiver not overlapping any rectangle in the given collection" | yOrigin yCorner aRectangle index rr | index _ startIndex. "Find the next intersecting rectangle from aCollection" [index <= aCollection size ifFalse:[^aBlock value: self]. aRectangle _ aCollection at: index. origin <= aRectangle corner and: [aRectangle origin <= corner]] whileFalse:[index _ index + 1]. "aRectangle is intersecting; process it" aRectangle origin y > origin y ifTrue: [rr _ origin corner: corner x @ (yOrigin _ aRectangle origin y). rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock] ifFalse: [yOrigin _ origin y]. aRectangle corner y < corner y ifTrue: [rr _ origin x @ (yCorner _ aRectangle corner y) corner: corner. rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock] ifFalse: [yCorner _ corner y]. aRectangle origin x > origin x ifTrue: [rr _ origin x @ yOrigin corner: aRectangle origin x @ yCorner. rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock]. aRectangle corner x < corner x ifTrue: [rr _ aRectangle corner x @ yOrigin corner: corner x @ yCorner. rr allAreasOutsideList: aCollection startingAt: index+1 do: aBlock].! ! !Rectangle methodsFor: 'transforming' stamp: 'JMM 10/21/2003 17:26'! newRectButtonPressedDo: newRectBlock "Track the outline of a new rectangle until mouse button changes. newFrameBlock produces each new rectangle from the previous. Only tracks while mouse is down." | rect newRect buttonNow aHand delay | delay _ Delay forMilliseconds: 10. buttonNow _ Sensor anyButtonPressed. rect _ self. Display border: rect width: 2 rule: Form reverse fillColor: Color gray. [buttonNow] whileTrue: [delay wait. buttonNow _ Sensor anyButtonPressed. newRect _ newRectBlock value: rect. newRect = rect ifFalse: [Display border: rect width: 2 rule: Form reverse fillColor: Color gray. Display border: newRect width: 2 rule: Form reverse fillColor: Color gray. rect _ newRect]]. Display border: rect width: 2 rule: Form reverse fillColor: Color gray. " pay the price for reading the sensor directly ; get this party started " Smalltalk isMorphic ifTrue: [aHand _ World activeHand. aHand newMouseFocus: nil; showTemporaryCursor: nil; flushEvents]. Sensor processEvent: Sensor createMouseEvent. ^ rect! ! !Rectangle methodsFor: 'transforming' stamp: 'JMM 10/21/2003 17:28'! newRectFrom: newRectBlock "Track the outline of a new rectangle until mouse button changes. newFrameBlock produces each new rectangle from the previous" | rect newRect buttonStart buttonNow aHand delay | delay _ Delay forMilliseconds: 10. buttonStart _ buttonNow _ Sensor anyButtonPressed. rect _ self. Display border: rect width: 2 rule: Form reverse fillColor: Color gray. [buttonNow == buttonStart] whileTrue: [delay wait. buttonNow _ Sensor anyButtonPressed. newRect _ newRectBlock value: rect. newRect = rect ifFalse: [Display border: rect width: 2 rule: Form reverse fillColor: Color gray. Display border: newRect width: 2 rule: Form reverse fillColor: Color gray. rect _ newRect]]. Display border: rect width: 2 rule: Form reverse fillColor: Color gray. " pay the price for reading the sensor directly ; get this party started " Smalltalk isMorphic ifTrue: [aHand _ World activeHand. aHand newMouseFocus: nil; showTemporaryCursor: nil; flushEvents]. Sensor processEvent: Sensor createMouseEvent. ^ rect! ! !Rectangle methodsFor: 'transforming' stamp: 'nk 7/5/2003 08:31'! translatedAndSquishedToBeWithin: aRectangle "Return an adjustment of the receiver that fits within aRectangle by - translating it to be within aRectangle if necessary, then - reducing its size, if necessary" ^ (self translatedToBeWithin: aRectangle) squishedWithin: aRectangle! ! !Rectangle class methodsFor: 'instance creation' stamp: 'btr 2/14/2003 16:29'! merging: listOfRects "A number of callers of merge: should use this method." | minX minY maxX maxY | listOfRects do: [:r | minX ifNil: [minX _ r topLeft x. minY _ r topLeft y. maxX _ r bottomRight x. maxY _ r bottomRight y] ifNotNil: [minX _ minX min: r topLeft x. minY _ minY min: r topLeft y. maxX _ maxX max: r bottomRight x. maxY _ maxY max: r bottomRight y]]. ^ minX@minY corner: maxX@maxY! ! !RectangleMorph methodsFor: 'accessing' stamp: 'ar 6/23/2001 16:06'! wantsToBeCachedByHand "Return true if the receiver wants to be cached by the hand when it is dragged around." self hasTranslucentColor ifTrue:[^false]. self bounds = self fullBounds ifTrue:[^true]. self submorphsDo:[:m| (self bounds containsRect: m fullBounds) ifFalse:[ m wantsToBeCachedByHand ifFalse:[^false]. ]. ]. ^true! ! !RectangleMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.613 g: 0.903 b: 1.0! ! !RectangleMorph commentStamp: 'kfr 10/27/2003 11:12' prior: 0! A subclass of BorderedMorph that supports different fillStyles. RectangleMorph diagonalPrototype openInWorld. RectangleMorph gradientPrototype openInWorld.! !RectangleMorph class methodsFor: 'as yet unclassified' stamp: 'nk 9/7/2004 11:44'! roundRectPrototype ^ self authoringPrototype useRoundedCorners color: ((Color r: 1.0 g: 0.3 b: 0.6) alpha: 0.5); borderWidth: 1; setNameTo: 'RoundRect'! ! !RectangleMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:12'! descriptionForPartsBin ^ self partName: 'Rectangle' categories: #('Graphics' 'Basic') documentation: 'A rectangular shape, with border and fill style'! ! !RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'! diagonalPrototype | rr | rr _ self authoringPrototype. rr useGradientFill; borderWidth: 0. rr fillStyle direction: rr extent. ^ rr! ! !RectangleMorph class methodsFor: 'parts bin' stamp: 'tk 11/14/2001 20:09'! gradientPrototype | rr | rr _ self authoringPrototype. rr useGradientFill; borderWidth: 0. ^ rr! ! !RectangleMorph class methodsFor: 'parts bin' stamp: 'nk 8/23/2004 18:12'! supplementaryPartsDescriptions ^ {DescriptionForPartsBin formalName: 'RoundRect' categoryList: #('Graphics' 'Basic') documentation: 'A rectangle with rounded corners' globalReceiverSymbol: #RectangleMorph nativitySelector: #roundRectPrototype. DescriptionForPartsBin formalName: 'Gradient' categoryList: #('Graphics' 'Basic') documentation: 'A rectangle with a horizontal gradient' globalReceiverSymbol: #RectangleMorph nativitySelector: #gradientPrototype. DescriptionForPartsBin formalName: 'Gradient (slanted)' categoryList: #('Graphics' 'Basic') documentation: 'A rectangle with a diagonal gradient' globalReceiverSymbol: #RectangleMorph nativitySelector: #diagonalPrototype}! ! !RectangleMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:23'! initialize self registerInFlapsRegistry. ! ! !RectangleMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 10:27'! registerInFlapsRegistry "Register the receiver in the system's flaps registry" self environment at: #Flaps ifPresent: [:cl | cl registerQuad: #(RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') forFlapNamed: 'Supplies'. cl registerQuad: #(RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') forFlapNamed: 'Supplies'. cl registerQuad: #(RectangleMorph roundRectPrototype 'RoundRect' 'A rectangle with rounded corners') forFlapNamed: 'PlugIn Supplies'. cl registerQuad: #(RectangleMorph authoringPrototype 'Rectangle' 'A rectangle') forFlapNamed: 'PlugIn Supplies'.]! ! !RectangleMorph class methodsFor: 'class initialization' stamp: 'asm 4/11/2003 12:39'! unload "Unload the receiver from global registries" self environment at: #Flaps ifPresent: [:cl | cl unregisterQuadsWithReceiver: self] ! ! !RectangleTest methodsFor: 'testing' stamp: 'FBS 1/23/2004 13:22'! testMergingDisjointRects | coll merge | coll := OrderedCollection new. coll add: (Rectangle left: -10 right: 0 top: -10 bottom: 0). coll add: (Rectangle left: 0 right: 10 top: 0 bottom: 10). merge := Rectangle merging: coll. self assert: merge = (Rectangle left: -10 right: 10 top: -10 bottom: 10).! ! !RectangleTest methodsFor: 'testing' stamp: 'FBS 1/23/2004 13:16'! testMergingNestedRects | coll merge | coll := OrderedCollection new. coll add: (Rectangle left: 1 right: 10 top: 1 bottom: 10). coll add: (Rectangle left: 4 right: 5 top: 4 bottom: 5). merge := Rectangle merging: coll. self assert: merge = coll first.! ! !RectangleTest methodsFor: 'testing' stamp: 'FBS 1/23/2004 13:18'! testMergingOverlappingRects | coll merge | coll := OrderedCollection new. coll add: (Rectangle left: 5 right: 10 top: 0 bottom: 15). coll add: (Rectangle left: 0 right: 15 top: 5 bottom: 10). merge := Rectangle merging: coll. self assert: merge = (Rectangle left: 0 right: 15 top: 0 bottom: 15).! ! !RectangleTest methodsFor: 'testing' stamp: 'FBS 1/23/2004 13:21'! testMergingTrivial | coll merge | coll := OrderedCollection new. coll add: (Rectangle left: 1 right: 1 top: 1 bottom: 1). merge := Rectangle merging: coll. self assert: merge = coll first. ! ! !RectangleTest methodsFor: 'testing' stamp: 'FBS 1/23/2004 13:18'! testMergingTwoRects | coll merge | coll := OrderedCollection new. coll add: (Rectangle left: 1 right: 1 top: 1 bottom: 1). coll add: (Rectangle left: 10 right: 10 top: 10 bottom: 10). merge := Rectangle merging: coll. self assert: merge = (Rectangle left: 1 right: 10 top: 1 bottom: 10).! ! !ReferenceMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:20'! highlight | str | isHighlighted := true. submorphs notEmpty ifTrue: [((str := submorphs first) isKindOf: StringMorph) ifTrue: [str color: self highlightColor] ifFalse: [self borderWidth: 1; borderColor: self highlightColor]]! ! !ReferenceMorph methodsFor: 'accessing' stamp: 'nk 6/12/2004 10:03'! isCurrentlyGraphical "Answer whether the receiver is currently showing a graphical face" | first | ^submorphs notEmpty and: [((first := submorphs first) isKindOf: ImageMorph) or: [first isSketchMorph]]! ! !ReferenceMorph methodsFor: 'accessing' stamp: 'dgd 2/22/2003 13:21'! unHighlight | str | isHighlighted := false. self borderWidth: 0. submorphs notEmpty ifTrue: [((str := submorphs first) isKindOf: StringMorph orOf: RectangleMorph) ifTrue: [str color: self regularColor]]! ! !ReferenceMorph methodsFor: 'events' stamp: 'nb 6/17/2003 12:25'! tabSelected "Called when the receiver is hit. First, bulletproof against someone having taken the structure apart. My own action basically requires that my grand-owner be a TabbedPalette. Note that the 'opening' script concept has been left behind here." | gramps | (owner isKindOf: IndexTabs) ifFalse: [^ Beeper beep]. ((gramps _ owner owner) isKindOf: TabbedPalette) ifTrue: [gramps selectTab: self]! ! !ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:48'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !ReferenceMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:49'! initialize "initialize the state of the receiver" super initialize. "" isHighlighted _ false. referent _ nil! ! !ReferenceMorph methodsFor: 'menu' stamp: 'dgd 8/30/2003 21:59'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add morph-specific items to the menu for the hand" | sketch | super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. self isCurrentlyTextual ifTrue: [aCustomMenu add: 'change label wording...' translated action: #changeTabText. aCustomMenu add: 'use graphical label' translated action: #useGraphicalTab] ifFalse: [aCustomMenu add: 'use textual label' translated action: #useTextualTab. aCustomMenu add: 'choose graphic...' translated action: #changeTabGraphic. (sketch _ self findA: SketchMorph) ifNotNil: [aCustomMenu add: 'repaint' translated target: sketch action: #editDrawing]]! ! !ReferenceMorph methodsFor: 'menu' stamp: 'gm 2/22/2003 12:51'! isCurrentlyTextual | first | ^((first := submorphs first) isKindOf: StringMorph) or: [first isTextMorph]! ! !ReferenceMorph methodsFor: 'naming' stamp: 'dgd 2/22/2003 13:21'! setNameTo: aString super setNameTo: aString. (submorphs notEmpty and: [submorphs first isKindOf: StringMorph]) ifTrue: [submorphs first contents: aString]! ! !ReferenceMorph class methodsFor: 'scripting' stamp: 'sw 9/26/2001 04:04'! additionsToViewerCategories "Answer a list of ( ) pairs that characterize the phrases this kind of morph wishes to add to various Viewer categories." ^ #((paintbox ((command makeNewDrawingIn: 'make a new drawing in the specified playfield' Player)))) ! ! !ReferenceStream class methodsFor: 'as yet unclassified' stamp: 'tk 4/19/2001 16:50'! on: aStream "Open a new ReferenceStream on a place to put the raw data." aStream class == ReadWriteStream ifTrue: [ self inform: 'Please consider using a RWBinaryOrTextStream instead of a ReadWriteStream']. ^ super on: aStream ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:19'! cleanUpChanges "Clean up the change sets" "ReleaseBuilder new cleanUpChanges" | projectChangeSetNames | "Delete all changesets except those currently used by existing projects." projectChangeSetNames _ Project allSubInstances collect: [:proj | proj changeSet name]. ChangeSorter removeChangeSetsNamedSuchThat: [:cs | (projectChangeSetNames includes: cs) not]. ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:28'! cleanUpEtoys "ReleaseBuilder new cleanUpEtoys" StandardScriptingSystem removeUnreferencedPlayers. (self confirm: 'Remove all projects and players?') ifFalse: [^self]. Project removeAllButCurrent. #('Morphic-UserObjects' 'EToy-UserObjects' 'Morphic-Imported' ) do: [:each | SystemOrganization removeSystemCategory: each]! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 15:33'! finalCleanup "ReleaseBuilder new finalCleanup" Smalltalk forgetDoIts. DataStream initialize. Behavior flushObsoleteSubclasses. "The pointer to currentMethod is not realy needed (anybody care to fix this) and often holds on to obsolete bindings" MethodChangeRecord allInstancesDo: [:each | each noteNewMethod: nil]. self cleanUpEtoys. SmalltalkImage current fixObsoleteReferences. Smalltalk flushClassNameCache. 3 timesRepeat: [ Smalltalk garbageCollect. Symbol compactSymbolTable. ]. ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:41'! finalStripping "ReleaseBuilder new finalStripping" ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'sd 9/26/2004 13:37'! fixObsoleteReferences "ReleaseBuilder new fixObsoleteReferences" | informee obsoleteBindings obsName realName realClass | Preference allInstances do: [:each | informee _ each instVarNamed: #changeInformee. ((informee isKindOf: Behavior) and: [informee isObsolete]) ifTrue: [ Transcript show: each name; cr. each instVarNamed: #changeInformee put: (Smalltalk at: (informee name copyReplaceAll: 'AnObsolete' with: '') asSymbol)]]. CompiledMethod allInstances do: [:method | obsoleteBindings _ method literals select: [:literal | literal isVariableBinding and: [literal value isBehavior] and: [literal value isObsolete]]. obsoleteBindings do: [:binding | obsName _ binding value name. Transcript show: obsName; cr. realName _ obsName copyReplaceAll: 'AnObsolete' with: ''. realClass _ Smalltalk at: realName asSymbol ifAbsent: [UndefinedObject]. binding isSpecialWriteBinding ifTrue: [binding privateSetKey: binding key value: realClass] ifFalse: [binding key: binding key value: realClass]]]. Behavior flushObsoleteSubclasses. Smalltalk garbageCollect; garbageCollect. SystemNavigation default obsoleteBehaviors size > 0 ifTrue: [SystemNavigation default inspect]! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:19'! initialCleanup "Perform various image cleanups in preparation for making a Squeak gamma release candidate image." "ReleaseBuilder new initialCleanup" Undeclared removeUnreferencedKeys. StandardScriptingSystem initialize. (Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents']. Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared']. Browser initialize. ScriptingSystem deletePrivateGraphics. "?" self cleanUpChanges. ChangeSet current clear. ChangeSet current name: 'Unnamed1'. Smalltalk garbageCollect. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. Smalltalk garbageCollect. ScheduledControllers _ nil. Smalltalk garbageCollect. SMSqueakMap default purge. ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 16:25'! installPreferences Preferences initialize. Preferences chooseInitialSettings. ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/26/2004 11:02'! installReleaseSpecifics "ReleaseBuilder new installReleaseSpecifics" ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:53'! installVersionInfo "ReleaseBuilder new installVersionInfo" ! ! !ReleaseBuilder methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:58'! prepareReleaseImage "Perform various image cleanups in preparation for making a Squeak gamma release candidate image." "ReleaseBuilder new prepareReleaseImage" (self confirm: 'Are you sure you want to prepare a release image? This will perform several irreversible cleanups on this image.') ifFalse: [^ self]. self initialCleanup; installPreferences; finalStripping; installReleaseSpecifics; finalCleanup; installVersionInfo ! ! !ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:35'! makeSqueaklandRelease "ReleaseBuilder new makeSqueaklandRelease" self makeSqueaklandReleasePhasePrepare; makeSqueaklandReleasePhaseStripping; makeSqueaklandReleasePhaseFinalSettings; makeSqueaklandReleasePhaseCleanup! ! !ReleaseBuilder methodsFor: 'squeakland' stamp: 'nk 2/22/2005 15:27'! makeSqueaklandReleasePhaseCleanup "ReleaseBuilder new makeSqueaklandReleasePhaseCleanup" Browser initialize. ChangeSorter removeChangeSetsNamedSuchThat: [:cs | cs name ~= ChangeSet current name]. ChangeSet current clear. ChangeSet current name: 'Unnamed1'. Smalltalk garbageCollect. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. "Remove existing player references" References keys do: [:k | References removeKey: k]. Smalltalk garbageCollect. ScheduledControllers := nil. Behavior flushObsoleteSubclasses. Smalltalk garbageCollect; garbageCollect. SystemNavigation default obsoleteBehaviors isEmpty ifFalse: [self error: 'Still have obsolete behaviors']. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. Smalltalk fixObsoleteReferences. Smalltalk abandonTempNames. Smalltalk zapAllOtherProjects. Smalltalk forgetDoIts. Smalltalk flushClassNameCache. 3 timesRepeat: [Smalltalk garbageCollect. Symbol compactSymbolTable]! ! !ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:36'! makeSqueaklandReleasePhaseFinalSettings "ReleaseBuilder new makeSqueaklandReleasePhaseFinalSettings" | serverName serverURL serverDir updateServer highestUpdate newVersion | ProjectLauncher splashMorph: (FileDirectory default readOnlyFileNamed: 'scripts\SqueaklandSplash.morph') fileInObjectAndCode. "Dump all morphs so we don't hold onto anything" World submorphsDo:[:m| m delete]. #( (honorDesktopCmdKeys false) (warnIfNoChangesFile false) (warnIfNoSourcesFile false) (showDirectionForSketches true) (menuColorFromWorld false) (unlimitedPaintArea true) (useGlobalFlaps false) (mvcProjectsAllowed false) (projectViewsInWindows false) (automaticKeyGeneration true) (securityChecksEnabled true) (showSecurityStatus false) (startInUntrustedDirectory true) (warnAboutInsecureContent false) (promptForUpdateServer false) (fastDragWindowForMorphic false) (externalServerDefsOnly true) (expandedFormat false) (allowCelesteTell false) (eToyFriendly true) (eToyLoginEnabled true) (magicHalos true) (mouseOverHalos true) (biggerHandles false) (selectiveHalos true) (includeSoundControlInNavigator true) (readDocumentAtStartup true) (preserveTrash true) (slideDismissalsToTrash true) ) do:[:spec| Preferences setPreference: spec first toValue: spec last]. "Workaround for bug" Preferences enable: #readDocumentAtStartup. World color: (Color r: 0.9 g: 0.9 b: 1.0). "Clear all server entries" ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each]. SystemVersion current resetHighestUpdate. "Add the squeakalpha update stream" serverName _ 'Squeakalpha'. serverURL _ 'squeakalpha.org'. serverDir _ serverURL , '/'. updateServer _ ServerDirectory new. updateServer server: serverURL; directory: 'updates/'; altUrl: serverDir; user: 'sqland'; password: nil. Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}. "Add the squeakland update stream" serverName _ 'Squeakland'. serverURL _ 'squeakland.org'. serverDir _ serverURL , '/'. updateServer _ ServerDirectory new. updateServer server: serverURL; directory: 'public_html/updates/'; altUrl: serverDir. Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}. highestUpdate _ SystemVersion current highestUpdate. (self confirm: 'Reset highest update (' , highestUpdate printString , ')?') ifTrue: [SystemVersion current highestUpdate: 0]. newVersion _ FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString. SystemVersion newVersion: newVersion. (self confirm: self version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. ! ! !ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:35'! makeSqueaklandReleasePhasePrepare "ReleaseBuilder new makeSqueaklandReleasePhasePrepare" Undeclared removeUnreferencedKeys. StandardScriptingSystem initialize. Preferences initialize. "(Object classPool at: #DependentsFields) size > 1 ifTrue: [self error:'Still have dependents']." Undeclared isEmpty ifFalse: [self error:'Please clean out Undeclared']. "Dump all projects" Project allSubInstancesDo:[:prj| prj == Project current ifFalse:[Project deletingProject: prj]]. "Set new look so we don't need older fonts later" StandardScriptingSystem applyNewEToyLook. Browser initialize. ScriptingSystem deletePrivateGraphics. ChangeSorter removeChangeSetsNamedSuchThat: [:cs| cs name ~= ChangeSet current name]. ChangeSet current clear. ChangeSet current name: 'Unnamed1'. Smalltalk garbageCollect. "Reinitialize DataStream; it may hold on to some zapped entitities" DataStream initialize. "Remove existing player references" References keys do:[:k| References removeKey: k]. Smalltalk garbageCollect. ScheduledControllers _ nil. Smalltalk garbageCollect. ! ! !ReleaseBuilder methodsFor: 'squeakland' stamp: 'sd 9/26/2004 13:35'! makeSqueaklandReleasePhaseStripping "ReleaseBuilder new makeSqueaklandReleasePhaseStripping" #(#Helvetica #Palatino #Courier #ComicSansMS ) do: [:n | TextConstants removeKey: n ifAbsent: []]. Smalltalk at: #Player ifPresent: [:superCls | superCls allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]. cls := nil]]. Smalltalk garbageCollect. Smalltalk discardFFI; discardSUnit; discardSpeech; yourself. "discardMVC;" SystemOrganization removeEmptyCategories. Smalltalk garbageCollect. ScheduledControllers := nil. Behavior flushObsoleteSubclasses. Smalltalk garbageCollect; garbageCollect. DataStream initialize. Smalltalk fixObsoleteReferences! ! !ReleaseBuilder commentStamp: '' prior: 0! I'm responsible to help people releasing various distribution of Squeak! !ReleaseBuilderDeveloper methodsFor: 'utilities' stamp: 'mir 11/26/2004 16:18'! cleanUpChanges "Clean up the change sets" "ReleaseBuilderDeveloper new cleanUpChanges" ! ! !ReleaseBuilderDeveloper methodsFor: 'utilities' stamp: 'gk 2/28/2005 14:47'! installReleaseSpecifics "Currently just clear and add the ServerDirectories and update streams we want as default." "Clear all server entries" ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each]. "Add default entries, added an entry for the new file area. The others are the current ones that see to work as of 2005-02-28 and I recreated them using source." ServerDirectory addServer: (ServerDirectory new type: #ftp; user: ''; server: 'box1.squeakfoundation.org'; altUrl: 'http://box1.squeakfoundation.org/files'; directory: 'files'; keepAlive: false) named: 'Squeak.org Archive'. ServerDirectory addServer: (ServerDirectory new type: #ftp; server: 'st.cs.uiuc.edu'; user: 'anonymous'; directory: '/Smalltalk/Squeak'; keepAlive: false) named: 'UIUC Archive'. ServerDirectory addServer: (ServerDirectory new type: #ftp; server: 'ftp.create.ucsb.edu'; user: 'anonymous'; directory: '/pub/Smalltalk/Squeak'; keepAlive: false) named: 'UCSBCreate Archive'. ServerDirectory addServer: SuperSwikiServer defaultSuperSwiki named: 'Bob SuperSwiki'. ServerDirectory addServer: (SuperSwikiServer new type: #http; server: 'squeakland.org:8080'; altUrl: 'http://www.squeakland.org/uploads'; directory: '/super/SuperSwikiProj'; keepAlive: false; acceptsUploads: true) named: 'Squeakland SuperSwiki'. ServerDirectory addServer: (HTTPServerDirectory new type: #ftp; user: 'sqland'; server: 'www.squeakland.org'; altUrl: 'http://www.squeakland.org/projects'; directory: 'projects'; keepAlive: false) named: 'Squeakland Projects'. "Add the update streams here just as Squeakland does? serverName _ 'Squeakland'. serverURL _ 'squeakland.org'. serverDir _ serverURL , '/'. updateServer _ ServerDirectory new. updateServer server: serverURL; directory: 'public_html/updates/'; altUrl: serverDir. Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}. " ! ! !ReleaseBuilderDeveloper commentStamp: 'gk 2/28/2005 13:27' prior: 0! This release builder subclass is used for the official Squeak distribution Basic, which currently is the base image of Squeak. Full is then built on top of Basic using a loadscript from SqueakMap. Minimal is constructed using another script from SqueakMap that removes packages that are included in Basic.! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:14'! finalCleanup "ReleaseBuilder new initialCleanup" Smalltalk abandonTempNames. Smalltalk zapAllOtherProjects. super finalCleanup! ! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:40'! finalStripping "ReleaseBuilderSqueakland new finalStripping" #(#Helvetica #Palatino #Courier #ComicSansMS ) do: [:n | TextConstants removeKey: n ifAbsent: []]. Smalltalk at: #Player ifPresent: [:superCls | superCls allSubclassesDo: [:cls | cls isSystemDefined ifFalse: [cls removeFromSystem]. cls := nil]]. Smalltalk garbageCollect. Smalltalk discardFFI; discardSUnit; discardSpeech; yourself. "discardMVC;" SystemOrganization removeEmptyCategories. ! ! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:19'! initialCleanup "ReleaseBuilder new initialCleanup" Browser initialize. ChangeSorter removeChangeSetsNamedSuchThat: [:cs| cs name ~= ChangeSet current name]. super initialCleanup! ! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 16:30'! installPreferences #( (honorDesktopCmdKeys false) (warnIfNoChangesFile false) (warnIfNoSourcesFile false) (showDirectionForSketches true) (menuColorFromWorld false) (unlimitedPaintArea true) (useGlobalFlaps false) (mvcProjectsAllowed false) (projectViewsInWindows false) (automaticKeyGeneration true) (securityChecksEnabled true) (showSecurityStatus false) (startInUntrustedDirectory true) (warnAboutInsecureContent false) (promptForUpdateServer false) (fastDragWindowForMorphic false) (externalServerDefsOnly true) (expandedFormat false) (allowCelesteTell false) (eToyFriendly true) (eToyLoginEnabled true) (magicHalos true) (mouseOverHalos true) (biggerHandles false) (selectiveHalos true) (includeSoundControlInNavigator true) (readDocumentAtStartup true) (preserveTrash true) (slideDismissalsToTrash true) (propertySheetFromHalo true) ) do:[:spec| Preferences setPreference: spec first toValue: spec last]. "Workaround for bug" Preferences enable: #readDocumentAtStartup. ! ! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:51'! installReleaseSpecifics "ReleaseBuilderSqueakland new installReleaseSpecifics" | serverName serverURL serverDir updateServer | ProjectLauncher splashMorph: (FileDirectory default readOnlyFileNamed: 'scripts\SqueaklandSplash.morph') fileInObjectAndCode. "Dump all morphs so we don't hold onto anything" World submorphsDo:[:m| m delete]. World color: (Color r: 0.9 g: 0.9 b: 1.0). "Clear all server entries" ServerDirectory serverNames do: [:each | ServerDirectory removeServerNamed: each]. SystemVersion current resetHighestUpdate. "Add the squeakalpha update stream" serverName _ 'Squeakalpha'. serverURL _ 'squeakalpha.org'. serverDir _ serverURL , '/'. updateServer _ ServerDirectory new. updateServer server: serverURL; directory: 'updates/'; altUrl: serverDir; user: 'sqland'; password: nil. Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}. "Add the squeakland update stream" serverName _ 'Squeakland'. serverURL _ 'squeakland.org'. serverDir _ serverURL , '/'. updateServer _ ServerDirectory new. updateServer server: serverURL; directory: 'public_html/updates/'; altUrl: serverDir. Utilities updateUrlLists addFirst: {serverName. {serverDir. }.}. ! ! !ReleaseBuilderSqueakland methodsFor: 'utilities' stamp: 'mir 11/25/2004 17:52'! installVersionInfo "ReleaseBuilderSqueakland new installVersionInfo" | highestUpdate newVersion | highestUpdate _ SystemVersion current highestUpdate. (self confirm: 'Reset highest update (' , highestUpdate printString , ')?') ifTrue: [SystemVersion current highestUpdate: 0]. newVersion _ FillInTheBlank request: 'New version designation:' initialAnswer: 'Squeakland 3.8.' , highestUpdate printString. SystemVersion newVersion: newVersion. (self confirm: self version , ' Is this the correct version designation? If not, choose no, and fix it.') ifFalse: [^ self]. ! ! !RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 3/4/2001 08:15'! shadowColor ^shadowColor! ! !RemoteCanvas methodsFor: 'accessing' stamp: 'RAA 3/3/2001 18:42'! shadowColor: x connection shadowColor: (shadowColor _ x). ! ! !RemoteCanvas methodsFor: 'drawing' stamp: 'yo 6/23/2003 18:09'! paragraph: paragraph bounds: bounds color: c | scanner | scanner _ CanvasCharacterScanner new. scanner canvas: self; text: paragraph text textStyle: paragraph textStyle; textColor: c; defaultTextColor: c. paragraph displayOn: self using: scanner at: bounds topLeft. ! ! !RemoteCanvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph in: bounds during: aBlock self flag: #roundedRudeness. aMorph wantsRoundedCorners ifFalse:[^aBlock value]. (self seesNothingOutside: (CornerRounder rectWithinCornersOf: bounds)) ifTrue: ["Don't bother with corner logic if the region is inside them" ^ aBlock value]. CornerRounder roundCornersOf: aMorph on: self in: bounds displayBlock: aBlock borderWidth: aMorph borderWidthForRounding corners: aMorph roundedCorners! ! !RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 3/3/2001 19:05'! clipBy: aRectangle during: aBlock | newCanvas newR | "Set a clipping rectangle active only during the execution of aBlock." newR _ transform localBoundsToGlobal: aRectangle. newCanvas _ RemoteCanvas connection: connection clipRect: (outerClipRect intersect: newR) transform: transform. newCanvas privateShadowColor: shadowColor. aBlock value: newCanvas. connection shadowColor: shadowColor.! ! !RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 3/3/2001 18:43'! privateShadowColor: x shadowColor _ x. ! ! !RemoteCanvas methodsFor: 'drawing-support' stamp: 'RAA 3/3/2001 18:43'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize | newCanvas | self flag: #bob. "do tranform and clip work together properly?" newCanvas := RemoteCanvas connection: connection clipRect: (aClipRect intersect: outerClipRect) transform: (transform composedWith: aDisplayTransform). newCanvas privateShadowColor: shadowColor. aBlock value: newCanvas. connection shadowColor: shadowColor.! ! !RemoteCanvas methodsFor: 'drawing-text' stamp: 'ar 12/31/2001 02:29'! drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c "Draw the given string in the given font and color clipped to the given rectangle. If the font is nil, the default font is used." "(innerClipRect intersects: (transform transformBoundsRect: boundsRect)) ifFalse: [ ^self ]." "clip rectangles seem to be all screwed up...." s isAllSeparators ifTrue: [ ^self ]. "is this correct?? it sure does speed things up!!" self drawCommand: [ :executor | executor drawString: s from: firstIndex to: lastIndex in: boundsRect font: fontOrNil color: c]! ! !RemoteControlledHandMorph class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 18:10'! on: aDecoder ^self new decoder: aDecoder! ! !RemoteFileStream methodsFor: 'as yet unclassified' stamp: 'tk 12/3/2003 21:04'! close "Write if we have data to write. FTP files are always binary to preserve the data exactly. The binary/text (ascii) flag is just for tell how the bits are delivered from a read." remoteFile writable ifTrue: [ remoteFile putFile: (self as: RWBinaryOrTextStream) reset named: remoteFile fileName]! ! !RemoteHandMorph methodsFor: 'connections' stamp: 'mir 5/13/2003 10:44'! startTransmittingEvents "Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer." (sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self]. Transcript show: 'Connecting to remote WorldMorph at '; show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr. sendSocket _ OldSimpleClientSocket new. sendSocket connectTo: self remoteHostAddress port: 54323. sendState _ #opening. owner primaryHand addEventListener: self.! ! !RemoteHandMorph methodsFor: 'connections' stamp: 'mir 5/13/2003 10:45'! startTransmittingEventsTo: remoteAddr "Attempt to broadcast events from this hand to a remote hand on the host with the given address. This method just creates the new socket and initiates a connection; it does not wait for the other end to answer." remoteAddress _ remoteAddr. (sendSocket notNil and:[sendSocket isConnected]) ifTrue:[^self]. Transcript show: 'Connecting to remote WorldMorph at '; show: (NetNameResolver stringFromAddress: self remoteHostAddress), ' ...'; cr. sendSocket _ OldSimpleClientSocket new. sendSocket connectTo: self remoteHostAddress port: 54323. sendState _ #opening. owner primaryHand addEventListener: self.! ! !RemoteHandMorph methodsFor: 'event handling' stamp: 'dgd 2/22/2003 18:51'! processEvents "Process user input events from the remote input devices." | evt | evt := self getNextRemoteEvent. [evt notNil] whileTrue: [evt type == #worldExtent ifTrue: [remoteWorldExtent := evt argument. ^self]. self handleEvent: evt. evt := self getNextRemoteEvent]! ! !RemoteHandMorph class methodsFor: 'utilities' stamp: 'mir 11/14/2002 17:37'! ensureNetworkConnected "Try to ensure that an intermittent network connection, such as a dialup or ISDN line, is actually connected. This is necessary to make sure a server is visible in order to accept an incoming connection." "RemoteHandMorph ensureNetworkConnected" Utilities informUser: 'Contacting domain name server...' during: [ NetNameResolver addressForName: 'squeak.org' timeout: 30]. ! ! !RemoteString methodsFor: 'accessing' stamp: 'ajh 1/18/2002 01:04'! fileStream "Answer the file stream with position set at the beginning of my string" | theFile | (sourceFileNumber == nil or: [(SourceFiles at: sourceFileNumber) == nil]) ifTrue: [^ nil]. theFile _ SourceFiles at: sourceFileNumber. theFile position: filePositionHi. ^ theFile! ! !RemoteString methodsFor: 'accessing' stamp: 'nk 11/26/2002 12:05'! last ^self string ifNotNilDo: [ :s | s last ]! ! !RemovedEvent methodsFor: 'testing' stamp: 'rw 6/30/2003 08:35'! isRemoved ^true! ! !RemovedEvent methodsFor: 'printing' stamp: 'rw 6/30/2003 09:31'! printEventKindOn: aStream aStream nextPutAll: 'Removed'! ! !RemovedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! changeKind ^#Removed! ! !RemovedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:28'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self methodKind with: self categoryKind with: self protocolKind! ! !RenamedEvent methodsFor: 'printing' stamp: 'rw 7/1/2003 11:34'! printEventKindOn: aStream aStream nextPutAll: 'Renamed'! ! !RenamedEvent methodsFor: 'testing' stamp: 'rw 7/1/2003 11:34'! isRenamed ^true! ! !RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'! newName ^ newName! ! !RenamedEvent methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:18'! newName: aName newName := aName! ! !RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:00'! oldName ^oldName! ! !RenamedEvent methodsFor: 'accessing' stamp: 'rw 7/1/2003 12:01'! oldName: aName oldName := aName! ! !RenamedEvent class methodsFor: 'accessing' stamp: 'rw 7/10/2003 12:09'! changeKind ^#Renamed! ! !RenamedEvent class methodsFor: 'accessing' stamp: 'NS 1/20/2004 12:30'! supportedKinds "All the kinds of items that this event can take." ^ Array with: self classKind with: self categoryKind with: self protocolKind! ! !RenamedEvent class methodsFor: 'instance creation' stamp: 'NS 1/27/2004 12:19'! class: aClass category: cat oldName: oldName newName: newName ^(self class: aClass category: cat) oldName: oldName; newName: newName! ! !ReorganizedEvent methodsFor: 'testing' stamp: 'NS 1/27/2004 12:44'! isReorganized ^ true! ! !ReorganizedEvent methodsFor: 'printing' stamp: 'NS 1/27/2004 12:44'! printEventKindOn: aStream aStream nextPutAll: 'Reorganized'! ! !ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'! changeKind ^#Reorganized! ! !ReorganizedEvent class methodsFor: 'accessing' stamp: 'NS 1/27/2004 12:46'! supportedKinds ^Array with: self classKind! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 23:08'! forgetObsolete "Forget obsolete locators, e.g., those that haven't been referenced and not been stored on a file." locatorMap keys "copy" do:[:k| (locatorMap at: k) localFileName ifNil:[locatorMap removeKey: k]].! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 3/3/2001 19:49'! initialize | fd pvt | originalMap _ IdentityDictionary new. stubMap _ IdentityDictionary new. locatorMap _ IdentityDictionary new. internalStubs _ IdentityDictionary new. fd _ ScriptingSystem formDictionary. pvt _ ScriptingSystem privateGraphics asSet. fd keysAndValuesDo:[:sel :form| (pvt includes: sel) ifFalse:[ internalStubs at: form put: (DiskProxy global: #ScriptingSystem selector: #formAtKey:extent:depth: args: {sel. form extent. form depth})]].! ! !ResourceCollector methodsFor: 'initialize' stamp: 'ar 2/27/2001 22:36'! initializeFrom: aResourceManager "Initialize the receiver from aResourceManager." aResourceManager resourceMap keysAndValuesDo:[:loc :res| (res notNil) ifTrue:[locatorMap at: res put: loc. loc localFileName: nil]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:32'! baseUrl ^baseUrl! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:39'! baseUrl: aString baseUrl _ aString. baseUrl isEmpty ifFalse:[ baseUrl last = $/ ifFalse:[baseUrl _ baseUrl copyWith: $/]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:23'! localDirectory ^localDirectory! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/24/2001 22:24'! localDirectory: aDirectory localDirectory _ aDirectory! ! !ResourceCollector methodsFor: 'accessing' stamp: 'tk 6/28/2001 15:58'! locatorMap "allow outsiders to store in it. For files that are not resources that do want to live in the resource directory locally and on the server. (.t files for example)" ^locatorMap! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:54'! locators ^locatorMap values! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:07'! locatorsDo: aBlock ^locatorMap valuesDo: aBlock! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! noteResource: aResourceStub replacing: anObject "Remember the fact that we need to load aResource which will replace anObject." stubMap at: aResourceStub put: anObject.! ! !ResourceCollector methodsFor: 'accessing' stamp: 'mir 10/29/2003 13:33'! objectForDataStream: refStream fromForm: aForm "Return a replacement for aForm to be stored instead" | stub fName copy loc fullSize nameAndSize | "First check if the form is one of the intrinsic Squeak forms" stub _ internalStubs at: aForm ifAbsent:[nil]. stub ifNotNil:[ refStream replace: aForm with: stub. ^stub]. "Now see if we have created the stub already (this may happen if for instance some form is shared)" stub _ originalMap at: aForm ifAbsent:[nil]. stub ifNotNil:[^aForm]. aForm hibernate. aForm bits class == FormStub ifTrue:[^nil]. "something is wrong" "too small to be of interest" "(aForm bits byteSize < 4096) ifTrue:[^aForm]." "We'll turn off writing out forms until we figure out how to reliably deal with resources" true ifTrue: [^aForm]. "Create our stub form" stub _ FormStub extent: (aForm width min: 32) @ (aForm height min: 32) depth: (aForm depth min: 8). aForm displayScaledOn: stub. aForm hibernate. "Create a copy of the original form which we use to store those bits" copy _ Form extent: aForm extent depth: aForm depth bits: nil. copy setResourceBits: aForm bits. "Get the locator for the form (if we have any)" loc _ locatorMap at: aForm ifAbsent:[nil]. "Store the resource file" nameAndSize _ self writeResourceForm: copy locator: loc. fName _ nameAndSize first. fullSize _ nameAndSize second. ProgressNotification signal: '2:resourceFound' extra: stub. stub hibernate. "See if we need to assign a new locator" (loc notNil and:[loc hasRemoteContents not]) ifTrue:[ "The locator describes some local resource. If we're preparing to upload the entire project to a remote server, make it a remote URL instead." " (baseUrl isEmpty not and:[baseUrl asUrl hasRemoteContents]) ifTrue:[loc urlString: baseUrl, fName]. " baseUrl isEmpty not ifTrue:[loc urlString: self resourceDirectory , fName]]. loc ifNil:[ loc _ ResourceLocator new urlString: self resourceDirectory , fName. locatorMap at: aForm put: loc]. loc localFileName: (localDirectory fullNameFor: fName). loc resourceFileSize: fullSize. stub locator: loc. "Map old against stub form" aForm setResourceBits: stub. originalMap at: aForm put: copy. stubMap at: stub put: aForm. locatorMap at: aForm put: loc. "note: *must* force aForm in out pointers if in IS or else won't get #comeFullyUpOnReload:" refStream replace: aForm with: aForm. ^aForm! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 22:59'! removeLocator: loc locatorMap keys "copy" do:[:k| (locatorMap at: k) = loc ifTrue:[locatorMap removeKey: k]].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:21'! replaceAll "Replace all resources by their originals. Done after the resource have been collected to get back to the original state." originalMap keysAndValuesDo:[:k :v| v ifNotNil:[k replaceByResource: v]. ].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'mir 6/21/2001 14:51'! resourceDirectory resourceDirectory ifNil: [resourceDirectory _ self baseUrl copyFrom: 1 to: (self baseUrl lastIndexOf: $/)]. ^resourceDirectory! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:08'! resourceFileNames "Return a list of all the resource files created" ^locatorMap values asArray collect:[:loc| loc localFileName].! ! !ResourceCollector methodsFor: 'accessing' stamp: 'ar 2/27/2001 17:01'! stubMap ^stubMap! ! !ResourceCollector methodsFor: 'objects from disk' stamp: 'ar 2/24/2001 22:37'! objectForDataStream: refStream "This should never happen; when projects get written they must be decoupled from the resource collector. If you get the error message below something is seriously broken." self error:'Cannot write resource manager'! ! !ResourceCollector methodsFor: 'resource writing' stamp: 'yo 11/13/2002 23:30'! writeResourceForm: aForm fromLocator: aLocator "The given form has been externalized before. If it was reasonably compressed, use the bits of the original data - this allows us to recycle GIF, JPEG, PNG etc. data without using the internal compression (which is in most cases inferior). If necessary the data will be retrieved from its URL location. This retrieval is done only if the resouce comes from either * the local disk (in which case the file has never been published) * the browser cache (in which case we don't cache the resource locally) In any other case we will *not* attempt to retrieve it, because doing so can cause the system to connect to the network which is probably not what we want. It should be a rare case anyways; could only happen if one clears the squeak cache selectively." | fName fStream url data | "Try to be smart about the name of the file" fName _ (aLocator urlString includes: $:) ifTrue: [ url _ aLocator urlString asUrl. url path last] ifFalse: [aLocator urlString]. fName isEmptyOrNil ifFalse:[fName _ fName asFileName]. (fName isEmptyOrNil or:[localDirectory isAFileNamed: fName]) ifTrue:[ "bad luck -- duplicate name" fName _ localDirectory nextNameFor:'resource' extension: (FileDirectory extensionFor: aLocator urlString)]. "Let's see if we have cached it locally" ResourceManager lookupCachedResource: self baseUrl , aLocator urlString ifPresentDo:[:stream | data _ stream upToEnd]. "Check if the cache entry is without qualifying baseUrl. Workaround for older versions." data ifNil:[ ResourceManager lookupCachedResource: aLocator urlString ifPresentDo:[:stream | data _ stream upToEnd]]. data ifNil:[ "We don't have it cached locally. Retrieve it from its original location." ((url notNil and: [url hasRemoteContents]) and:[HTTPClient isRunningInBrowser not]) ifTrue:[^nil]. "see note above" (Url schemeNameForString: aLocator urlString) ifNil: [^nil]. data _ HTTPLoader default retrieveContentsFor: aLocator urlString. data ifNil:[^nil]. data _ data content. ]. "data size > aForm bits byteSize ifTrue:[^nil]." fStream _ localDirectory newFileNamed: fName. fStream binary. fStream nextPutAll: data. fStream close. ^{fName. data size}! ! !ResourceCollector methodsFor: 'resource writing' stamp: 'ar 9/23/2002 03:34'! writeResourceForm: aForm locator: aLocator "Store the given form on a file. Return an array with the name and the size of the file" | fName fStream fullSize result writerClass | aLocator ifNotNil:[ result _ self writeResourceForm: aForm fromLocator: aLocator. result ifNotNil:[^result] "else fall through" ]. fName _ localDirectory nextNameFor:'resource' extension:'form'. fStream _ localDirectory newFileNamed: fName. fStream binary. aForm storeResourceOn: fStream. false ifTrue:[ "What follows is a Really, REALLY bad idea. I leave it in as a reminder of what you should NOT do. PART I: Using JPEG or GIF compression on forms where we don't have the original data means loosing both quality and alpha information if present..." writerClass _ ((Smalltalk includesKey: #JPEGReaderWriter2) and: [(Smalltalk at: #JPEGReaderWriter2) new isPluginPresent]) ifTrue: [(Smalltalk at: #JPEGReaderWriter2)] ifFalse: [GIFReadWriter]. writerClass putForm: aForm onStream: fStream. fStream open. fullSize _ fStream size. fStream close. ]. "Compress contents here" true ifTrue:[ "...PART II: Using the builtin compression which combines RLE+ZIP is AT LEAST AS GOOD as PNG and how much more would you want???" fStream position: 0. fStream compressFile. localDirectory deleteFileNamed: fName. localDirectory rename: fName, FileDirectory dot, 'gz' toBe: fName. fStream _ localDirectory readOnlyFileNamed: fName. fullSize _ fStream size. fStream close. ]. ^{fName. fullSize}! ! !ResourceCollector commentStamp: '' prior: 0! The ResourceCollector collects resources that are encountered during project loading or publishing. It merely decouples the places where resources are held from the core object enumeration so that resources can be stored independently from what is enumerated for publishing.! !ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! current ^Current! ! !ResourceCollector class methodsFor: 'accessing' stamp: 'ar 2/24/2001 21:41'! current: aResourceManager Current _ aResourceManager! ! !ResourceLocator methodsFor: 'accessing'! adjustToDownloadUrl: downloadUrl "Adjust to the fully qualified URL for this resource." self urlString: (ResourceLocator make: self urlString relativeTo: downloadUrl) unescapePercents! ! !ResourceLocator methodsFor: 'accessing' stamp: 'mir 6/19/2001 16:55'! adjustToRename: newName from: oldName "Adjust to the fully qualified URL for this resource." self urlString: (self urlString copyReplaceAll: oldName with: newName)! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:00'! localFileName ^localFileName! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:01'! localFileName: aString localFileName _ aString! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! resourceFileSize ^fileSize! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 3/2/2001 18:13'! resourceFileSize: aNumber fileSize _ aNumber! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! urlString ^urlString! ! !ResourceLocator methodsFor: 'accessing' stamp: 'ar 2/27/2001 19:57'! urlString: aString urlString _ aString.! ! !ResourceLocator methodsFor: 'testing' stamp: 'ar 2/27/2001 22:11'! hasRemoteContents "Return true if we describe a resource which is non-local, e.g., on some remote server." (urlString indexOf: $:) = 0 ifTrue:[^false]. "no scheme" ^urlString asUrl hasRemoteContents! ! !ResourceLocator methodsFor: 'printing' stamp: 'ar 2/27/2001 20:02'! printOn: aStream super printOn: aStream. aStream nextPut: $(; print: urlString; nextPut: $)! ! !ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'! = aLocator ^ self species == aLocator species and: [self urlString = aLocator urlString] ! ! !ResourceLocator methodsFor: 'comparing' stamp: 'ar 2/27/2001 20:02'! hash ^urlString hash! ! !ResourceLocator methodsFor: 'comparing' stamp: 'tk 7/5/2001 22:10'! species ^ResourceLocator! ! !ResourceLocator commentStamp: '' prior: 0! Describes where a resource can be found. Instance variables: urlString The URL of the resource fileSize The size of the resource localFileName When non-nil, the place where this resource was/is stored.! !ResourceLocator class methodsFor: 'utilities'! make: newURLString relativeTo: oldURLString "Local file refs are not handled well, so work around here" ^((oldURLString includesSubString: '://') not and: [(newURLString includesSubString: '://') not]) ifTrue: [oldURLString , (UnixFileDirectory localNameFor: newURLString)] ifFalse: [(newURLString asUrlRelativeTo: oldURLString asUrl) toText]! ! !ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'! initialize "So resources may get garbage collected if possible" self reset.! ! !ResourceManager methodsFor: 'initialize' stamp: 'mir 6/18/2001 22:49'! initializeFrom: aCollector "Initialize the receiver from the given resource collector. None of the resources have been loaded yet, so make register all resources as unloaded." | newLoc | aCollector stubMap keysAndValuesDo:[:stub :res| newLoc _ stub locator. resourceMap at: newLoc put: res. "unloaded add: newLoc." ].! ! !ResourceManager methodsFor: 'initialize' stamp: 'ar 2/27/2001 16:54'! reset "Clean out everything" resourceMap _ WeakValueDictionary new. loaded _ Set new. unloaded _ Set new.! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:50'! addResource: anObject locator: aLocator resourceMap at: aLocator put: anObject. loaded add: aLocator.! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 3/2/2001 20:56'! addResource: anObject url: urlString ^self addResource: anObject locator: (ResourceLocator new urlString: urlString)! ! !ResourceManager methodsFor: 'accessing' stamp: 'mir 6/26/2001 17:33'! adjustToDownloadUrl: downloadUrl "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." downloadUrl isEmptyOrNil ifTrue: [^self]. self resourceMap keysDo:[:locator | locator adjustToDownloadUrl: downloadUrl]. self resourceMap rehash. unloaded rehash! ! !ResourceManager methodsFor: 'accessing'! adjustToNewServer: newResourceUrl from: oldResourceUrl "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." | urlMap oldUrl newUrl | newResourceUrl isEmptyOrNil ifTrue: [^self]. urlMap _ Dictionary new. self resourceMap keysDo: [:locator | "Local file refs are not handled well, so work around here" oldUrl _ ResourceLocator make: locator urlString relativeTo: oldResourceUrl. newUrl _ ResourceLocator make: locator urlString relativeTo: newResourceUrl. oldUrl ~= newUrl ifTrue: [urlMap at: oldUrl asString unescapePercents put: newUrl asString unescapePercents]]. self resourceMap rehash. unloaded rehash. urlMap keysAndValuesDo: [:old :new | ResourceManager renameCachedResource: old to: new]! ! !ResourceManager methodsFor: 'accessing' stamp: 'mir 6/21/2001 16:02'! adjustToRename: newName from: oldName "Adjust the resource manager to the current download location. A project might have been moved manually to a different location or server." | urlMap oldUrl | newName isEmptyOrNil ifTrue: [^self]. urlMap _ Dictionary new. self resourceMap keysDo: [:locator | oldUrl _ locator urlString. locator adjustToRename: newName from: oldName. urlMap at: oldUrl put: locator urlString]. self resourceMap rehash. unloaded rehash. urlMap keysAndValuesDo: [:old :new | ResourceManager renameCachedResource: old to: new]! ! !ResourceManager methodsFor: 'accessing' stamp: 'mir 8/21/2001 17:07'! makeAllProjectResourcesLocalTo: resourceUrl "Change the urls in the resource locators so project specific resources are stored and referenced locally. Project specific resources are all those that are kept locally in any of the project's versions." | locators locUrl locBase lastSlash projectBase localResource isExternal | "Construct the version neutral project base" resourceUrl isEmptyOrNil ifTrue: [^self]. projectBase _ resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) - 1. locators _ OrderedCollection new. self resourceMap keysAndValuesDo:[:loc :res | res ifNotNil: [locators add: loc]]. locators do: [:locator | locUrl _ locator urlString. locUrl ifNotNil: [ lastSlash _ locUrl lastIndexOf: $/. lastSlash > 0 ifTrue: [ locBase _ locUrl copyFrom: 1 to: lastSlash - 1. locBase _ locBase copyFrom: 1 to: (((locBase lastIndexOf: $.) - 1) max: 0). isExternal _ projectBase ~= locBase. (isExternal not or: [self localizeAllExternalResources]) ifTrue: [ localResource _ locUrl copyFrom: lastSlash+1 to: locUrl size. "Update the cache entry to point to the new resource location" ResourceManager renameCachedResource: locUrl to: (resourceUrl , localResource) external: isExternal. locator urlString: localResource]]]]. self resourceMap rehash ! ! !ResourceManager methodsFor: 'accessing' stamp: 'ar 2/27/2001 20:57'! resourceMap ^resourceMap! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 5/30/2001 23:11'! installResource: aResource from: aStream locator: loc | repl | aResource ifNil:[^false]. "it went away, so somebody might have deleted it" (aStream == nil or:[aStream size = 0]) ifTrue:[^false]. "error?!!" repl _ aResource clone readResourceFrom: aStream asUnZippedStream. repl ifNotNil:[ aResource replaceByResource: repl. unloaded remove: loc. loaded add: loc. ^true ]. ^false! ! !ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'! loadCachedResources "Load all the resources that we have cached locally" | resource | self class reloadCachedResources. self prioritizedUnloadedResources do:[:loc| self class lookupCachedResource: loc urlString ifPresentDo:[:stream| resource _ resourceMap at: loc ifAbsent:[nil]. self installResource: resource from: stream locator: loc. (resource isForm) ifTrue:[ self formChangedReminder value. World displayWorldSafely]. ]. ].! ! !ResourceManager methodsFor: 'loading' stamp: 'nk 4/17/2004 19:50'! loaderProcess | loader requests req locator resource stream | loader _ HTTPLoader default. requests _ Dictionary new. self prioritizedUnloadedResources do:[:loc| req _ HTTPLoader httpRequestClass for: (self hackURL: loc urlString) in: loader. loader addRequest: req. requests at: req put: loc]. [stopFlag or:[requests isEmpty]] whileFalse:[ stopSemaphore waitTimeoutMSecs: 500. requests keys "need a copy" do:[:r| r isSemaphoreSignaled ifTrue:[ locator _ requests at: r. requests removeKey: r. stream _ r contentStream. resource _ resourceMap at: locator ifAbsent:[nil]. self class cacheResource: locator urlString stream: stream. self installResource: resource from: stream locator: locator. (resource isForm) ifTrue:[ WorldState addDeferredUIMessage: self formChangedReminder] ifFalse: [self halt]. ]. ]. ]. "Either done downloading or terminating process" stopFlag ifTrue:[loader abort]. loaderProcess _ nil. stopSemaphore _ nil.! ! !ResourceManager methodsFor: 'loading' stamp: 'tetha 3/6/2004 15:46'! preLoadFromArchive: aZipArchive cacheName: aFileName "Load the resources from the given zip archive" | orig nameMap resMap loc stream | self class reloadCachedResources. resMap _ Dictionary new. nameMap _ Dictionary new. unloaded do:[:locator| locator localFileName: nil. nameMap at: locator urlString put: locator. resMap at: locator urlString put: (resourceMap at: locator)]. aZipArchive members do:[:entry| stream _ nil. orig _ resMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil]. loc _ nameMap at: (self convertMapNameForBackwardcompatibilityFrom: entry fileName ) ifAbsent:[nil]. "note: orig and loc may be nil for non-resource members" (orig notNil and:[loc notNil]) ifTrue:[ stream _ entry contentStream. self installResource: orig from: stream locator: loc. stream reset. aFileName ifNil:[self class cacheResource: loc urlString stream: stream] ifNotNil:[self class cacheResource: loc urlString inArchive: aFileName]]. ].! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 18:16'! prioritizedUnloadedResources "Return an array of unloaded resource locators prioritized by some means" | list | list _ unloaded asArray. ^list sort:[:l1 :l2| (l1 resourceFileSize ifNil:[SmallInteger maxVal]) <= (l2 resourceFileSize ifNil:[SmallInteger maxVal])]! ! !ResourceManager methodsFor: 'loading' stamp: 'mir 6/18/2001 22:49'! registerUnloadedResources resourceMap keys do: [:newLoc | unloaded add: newLoc] ! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/3/2001 18:01'! startDownload "Start downloading unloaded resources" self stopDownload. unloaded isEmpty ifTrue:[^self]. self loadCachedResources. unloaded isEmpty ifTrue:[^self]. stopFlag _ false. stopSemaphore _ Semaphore new. loaderProcess _ [self loaderProcess] newProcess. loaderProcess priority: Processor lowIOPriority. loaderProcess resume.! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 3/2/2001 17:09'! stopDownload "Stop downloading unloaded resources" loaderProcess ifNil:[^self]. stopFlag _ true. stopSemaphore signal. [loaderProcess == nil] whileFalse:[(Delay forMilliseconds: 10) wait]. stopSemaphore _ nil.! ! !ResourceManager methodsFor: 'loading' stamp: 'ar 2/27/2001 21:42'! updateResourcesFrom: aCollector "We just assembled all the resources in a project. Include all that were newly found" self reset. "start clean" aCollector stubMap keysAndValuesDo:[:stub :res| "update all entries" resourceMap at: stub locator put: res. loaded add: stub locator. ].! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 19:25'! abandonResourcesThat: matchBlock "Private. Forget resources that match the given argument block" resourceMap keys "need copy" do:[:loc| (matchBlock value: loc) ifTrue:[ resourceMap removeKey: loc ifAbsent:[]. loaded remove: loc ifAbsent:[]. unloaded remove: loc ifAbsent:[]. ]. ].! ! !ResourceManager methodsFor: 'private' stamp: 'yo 1/12/2004 22:54'! fixJISX0208Resource | keys value url | keys _ resourceMap keys. keys do: [:key | value _ resourceMap at: key. url _ key urlString copy. url isOctetString not ifTrue: [url mutateJISX0208StringToUnicode]. resourceMap removeKey: key. key urlString: url. resourceMap at: key put: value. ]. ! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/3/2001 15:30'! formChangedReminder ^[World newResourceLoaded].! ! !ResourceManager methodsFor: 'private' stamp: 'ar 3/2/2001 17:22'! hackURL: urlString (urlString findString: '/SuperSwikiProj/') > 0 ifTrue:[^urlString copyReplaceAll: '/SuperSwikiProj/' with: '/uploads/'] ifFalse:[^urlString]! ! !ResourceManager methodsFor: 'private' stamp: 'mir 8/20/2001 17:12'! localizeAllExternalResources "Should be a preference later." ^true! ! !ResourceManager methodsFor: 'backward-compatibility' stamp: 'nk 7/30/2004 21:46'! convertMapNameForBackwardcompatibilityFrom: aString (SmalltalkImage current platformName = 'Mac OS' and: ['10*' match: SmalltalkImage current osVersion]) ifTrue: [^aString convertFromWithConverter: ShiftJISTextConverter new]. ^aString convertFromSystemString! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'ar 5/30/2001 23:21'! cacheResource: urlString inArchive: archiveName "Remember the given url as residing in the given archive" | fd file fullName | fullName _ 'zip://', archiveName. ((self resourceCache at: urlString ifAbsent:[#()]) anySatisfy:[:cache| cache = fullName]) ifTrue:[^self]. "don't cache twice" fd _ Project squeakletDirectory. "update cache" file _ [fd oldFileNamed: self resourceCacheName] on: FileDoesNotExistException do:[:ex| fd forceNewFileNamed: self resourceCacheName]. file setToEnd. file nextPutAll: urlString; cr. file nextPutAll: fullName; cr. file close. self addCacheLocation: fullName for: urlString.! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'yo 12/20/2003 02:12'! cacheResource: urlString stream: aStream | fd localName file buf | HTTPClient shouldUsePluginAPI ifTrue:[^self]. "use browser cache" (self resourceCache at: urlString ifAbsent:[#()]) size > 0 ifTrue:[^self]. "don't waste space" fd _ Project squeakletDirectory. localName _ fd nextNameFor: 'resource' extension:'cache'. file _ fd forceNewFileNamed: localName. buf _ ByteArray new: 10000. aStream binary. file binary. [aStream atEnd] whileFalse:[ buf _ aStream next: buf size into: buf. file nextPutAll: buf. ]. file close. "update cache" file _ [fd oldFileNamed: self resourceCacheName] on: FileDoesNotExistException do:[:ex| fd forceNewFileNamed: self resourceCacheName]. file setToEnd. file nextPutAll: urlString; cr. file nextPutAll: localName; cr. file close. self addCacheLocation: localName for: urlString. aStream position: 0. ! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'mir 9/15/2002 15:59'! lookupCachedResource: cachedUrlString ifPresentDo: streamBlock "See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource." | urlString candidates url stream | CachedResources ifNil:[^self]. candidates _ CachedResources at: cachedUrlString ifAbsent:[nil]. (self lookupCachedResource: cachedUrlString in: candidates ifPresentDo: streamBlock) ifTrue: [^self]. urlString _ self relocatedExternalResource: cachedUrlString. urlString ifNil: [^self]. candidates _ CachedResources at: urlString ifAbsent:[nil]. candidates ifNil: [ (url _ urlString asUrl) schemeName = 'file' ifTrue: [ stream _ [FileStream readOnlyFileNamed: url pathForFile] on: FileDoesNotExistException do:[:ex| ex return: nil]. stream ifNotNil: [[streamBlock value: stream] ensure: [stream close]]]] ifNotNil: [self lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock]! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 18:31'! lookupCachedResource: urlString in: candidates ifPresentDo: streamBlock "See if we have cached the resource described by the given url and if so, evaluate streamBlock with the cached resource." | sortedCandidates dir file | (candidates isNil or:[candidates size = 0]) ifTrue:[^false]. "First, try non-zip members (faster since no decompression is involved)" sortedCandidates _ (candidates reject:[:each| each beginsWith: 'zip://']), (candidates select:[:each| each beginsWith: 'zip://']). dir _ Project squeakletDirectory. sortedCandidates do:[:fileName| file _ self loadResource: urlString fromCacheFileNamed: fileName in: dir. file ifNotNil:[ [streamBlock value: file] ensure:[file close]. ^true]]. ^false! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'mir 6/21/2001 22:49'! lookupOriginalResourceCacheEntry: resourceFileName for: resourceUrl "See if we have cached the resource described by the given url in an earlier version of the same project on the same server. In that case we don't need to upload it again but rather link to it." | candidates resourceBase resourceMatch matchingUrls | CachedResources ifNil:[^nil]. "Strip the version number from the resource url" resourceBase _ resourceUrl copyFrom: 1 to: (resourceUrl lastIndexOf: $.) . "Now collect all urls that have the same resource base" resourceMatch _ resourceBase , '*/' , resourceFileName. matchingUrls _ self resourceCache keys select: [:entry | (resourceMatch match: entry) and: [(entry beginsWith: resourceUrl) not]]. matchingUrls isEmpty ifTrue: [^nil]. matchingUrls asSortedCollection do: [:entry | candidates _ (self resourceCache at: entry). candidates isEmptyOrNil ifFalse: [candidates do: [:candidate | candidate = resourceFileName ifTrue: [^entry]]]]. ^nil! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'sd 1/30/2004 15:21'! reloadCachedResources "ResourceManager reloadCachedResources" "Reload cached resources from the disk" | fd files stream url localName storeBack archiveName | CachedResources _ Dictionary new. LocalizedExternalResources _ nil. fd _ Project squeakletDirectory. files _ fd fileNames asSet. stream _ [fd readOnlyFileNamed: self resourceCacheName] on: FileDoesNotExistException do:[:ex| fd forceNewFileNamed: self resourceCacheName]. stream size < 50000 ifTrue:[stream _ ReadStream on: stream contentsOfEntireFile]. storeBack _ false. [stream atEnd] whileFalse:[ url _ stream upTo: Character cr. localName _ stream upTo: Character cr. (localName beginsWith: 'zip://') ifTrue:[ archiveName _ localName copyFrom: 7 to: localName size. (files includes: archiveName) ifTrue:[self addCacheLocation: localName for: url] ifFalse:[storeBack _ true]. ] ifFalse:[ (files includes: localName) ifTrue:[self addCacheLocation: localName for: url] ifFalse:[storeBack _ true] ]. ]. stream close. storeBack ifTrue:[ stream _ fd forceNewFileNamed: self resourceCacheName. CachedResources keysAndValuesDo:[:urlString :cacheLocs| cacheLocs do:[:cacheLoc| stream nextPutAll: urlString; cr. stream nextPutAll: cacheLoc; cr]. ]. stream close. ].! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'mir 8/21/2001 17:24'! renameCachedResource: urlString to: newUrlString "A project was renamed. Reflect this change by duplicating the cache entry to the new url." self renameCachedResource: urlString to: newUrlString external: true! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'mir 12/3/2001 13:14'! renameCachedResource: urlString to: newUrlString external: isExternal "A project was renamed. Reflect this change by duplicating the cache entry to the new url." | candidates | CachedResources ifNil:[ isExternal ifTrue: [self resourceCache "force init" ] ifFalse: [^self]]. candidates _ CachedResources at: urlString ifAbsent:[nil]. (candidates isNil or:[candidates size = 0]) ifFalse: [ candidates do: [:candidate | self addCacheLocation: candidate for: newUrlString]]. isExternal ifTrue: [self relocatedExternalResource: urlString to: newUrlString]! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'ar 8/23/2001 17:52'! resourceCache ^CachedResources ifNil:[ CachedResources _ Dictionary new. self reloadCachedResources. CachedResources].! ! !ResourceManager class methodsFor: 'resource caching' stamp: 'ar 3/3/2001 17:27'! resourceCacheName ^'resourceCache.map'! ! !ResourceManager class methodsFor: 'private-resources' stamp: 'mir 11/29/2001 16:19'! addCacheLocation: aString for: urlString | locations | locations _ CachedResources at: urlString ifAbsentPut: [#()]. (locations includes: aString) ifFalse: [CachedResources at: urlString put: ({aString} , locations)]! ! !ResourceManager class methodsFor: 'private-resources' stamp: 'ar 5/30/2001 23:55'! loadResource: urlString fromCacheFileNamed: fileName in: dir | archiveName file archive | (fileName beginsWith: 'zip://') ifTrue:[ archiveName _ fileName copyFrom: 7 to: fileName size. archive _ [dir readOnlyFileNamed: archiveName] on: FileDoesNotExistException do:[:ex| ex return: nil]. archive ifNil:[^nil]. archive isZipArchive ifTrue:[ archive _ ZipArchive new readFrom: archive. file _ archive members detect:[:any| any fileName = urlString] ifNone:[nil]]. file ifNotNil:[file _ file contentStream]. archive close. ] ifFalse:[ file _ [dir readOnlyFileNamed: fileName] on: FileDoesNotExistException do:[:ex| ex return: nil]. ]. ^file! ! !ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 15:50'! localizedExternalResources ^LocalizedExternalResources ifNil:[LocalizedExternalResources _ Dictionary new]! ! !ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:06'! relocatedExternalResource: urlString ^self localizedExternalResources at: urlString ifAbsent: [nil]! ! !ResourceManager class methodsFor: 'private-resources' stamp: 'mir 8/21/2001 16:00'! relocatedExternalResource: urlString to: newUrlString | originalURL | originalURL _ (self localizedExternalResources includesKey: urlString) ifTrue: [self localizedExternalResources at: urlString] ifFalse: [urlString]. self localizedExternalResources at: newUrlString put: originalURL! ! !ResultSpecification methodsFor: 'companion setter' stamp: 'sw 2/27/2001 09:15'! companionSetterSelector "Answer the companion setter, nil if none" ^ companionSetterSelector! ! !ResultSpecification methodsFor: 'refetch' stamp: 'sw 5/3/2001 00:07'! refetchFrequency "Answer the frequency with which the receiver should be refetched by a readout polling values from it, as in a Viewer. Answer nil if not ever to be refetched automatically" ^ refetchFrequency! ! !ResultSpecification methodsFor: 'refetch' stamp: 'sw 5/3/2001 00:29'! refetchFrequency: aFrequency "Set the refetch frequency" refetchFrequency _ aFrequency! ! !ResultSpecification methodsFor: 'result type' stamp: 'sw 2/27/2001 09:14'! resultType "Answer the reciever's result type" ^ type! ! !ResultSpecification methodsFor: 'result type' stamp: 'sw 2/24/2001 12:11'! resultType: aType "Set the receiver's resultType as specified" type _ aType! ! !ResultSpecification methodsFor: 'result type' stamp: 'sw 2/24/2001 12:12'! type "Answer the reciever's type" ^ type! ! !ResumableTestFailure methodsFor: 'camp smalltalk'! isResumable "Of course a ResumableTestFailure is resumable ;-)" ^true! ! !ResumableTestFailure methodsFor: 'camp smalltalk'! sunitExitWith: aValue self resume: aValue! ! !ResumableTestFailure commentStamp: '' prior: 0! A ResumableTestFailure triggers a TestFailure, but lets execution of the TestCase continue. this is useful when iterating through collections, and #assert: ing on each element. in combination with methods like testcase>>#assert:description:, this lets you run through a whole collection and note which tests pass. here''s an example: (1 to: 30) do: [ :each | self assert: each odd description: each printString, ' is even' resumable: true] for each element where #odd returns , the element will be printed to the Transcript. ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! errorTest 1 zork ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! failureLog ^SUnitNameResolver defaultLogDevice ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! failureTest self assert: false description: 'You should see me' resumable: true; assert: false description: 'You should see me too' resumable: true; assert: false description: 'You should see me last' resumable: false; assert: false description: 'You should not see me' resumable: true ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! isLogging ^false ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! okTest self assert: true ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! regularTestFailureTest self assert: false description: 'You should see me' ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! resumableTestFailureTest self assert: false description: 'You should see me' resumable: true; assert: false description: 'You should see me too' resumable: true; assert: false description: 'You should see me last' resumable: false; assert: false description: 'You should not see me' resumable: true ! ! !ResumableTestFailureTestCase methodsFor: 'Not categorized'! testResumable | result suite | suite := TestSuite new. suite addTest: (self class selector: #errorTest). suite addTest: (self class selector: #regularTestFailureTest). suite addTest: (self class selector: #resumableTestFailureTest). suite addTest: (self class selector: #okTest). result := suite run. self assert: result failures size = 2; assert: result errors size = 1 ! ! !ReturnNode methodsFor: 'printing' stamp: 'yo 8/2/2004 17:21'! expr ^ expr. ! ! !ReturnNode methodsFor: 'tiles' stamp: 'RAA 2/26/2001 06:44'! asMorphicSyntaxIn: parent ^parent returnNode: self expression: expr ! ! !ReverbSound methodsFor: 'sound generation' stamp: 'zz 3/2/2004 08:26'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol "Play my sound with reverberation." sound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol. self applyReverbTo: aSoundBuffer startingAt: startIndex count: n. ! ! !RuleDate methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! applyRuleTo: daysNamedInMonthList "Private - Answer the day of the month selected from dayOfMonth list by applying the receiver's rule." ^ daysNamedInMonthList perform: selectionRule! ! !RuleDate methodsFor: 'private' stamp: 'nk 6/2/2004 12:15'! basicUpdateForMonth: mm year: yyyy "Private - Answer the receiver after updating by applying the rule for the month, mm, of year, yyyy." | dayByRule daysNamedInMonth firstDayNamed | firstDayNamed := self dayInMonth: mm year: yyyy ofFirstDayNamed: dayOfWeek. daysNamedInMonth := (firstDayNamed to: self daysInMonth by: 7) asArray. dayByRule := self applyRuleTo: daysNamedInMonth. self start: (Date newDay: dayByRule month: mm year: yyyy). ! ! !RuleDate methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! dayInMonth: monthIn year: yearIn ofFirstDayNamed: dayNameIn "Private - Answer, the day in the month, monthIn, of year, yearIn, of the first day named, dayNameIn." | frstDayNdx dayName firstDay | dayName := dayNameIn asSymbol. frstDayNdx := (Date firstWeekdayOfMonth: monthIn year: yearIn) - 1. frstDayNdx = 0 ifTrue: [frstDayNdx := frstDayNdx + 7]. firstDay := 1. (Date nameOfDay: frstDayNdx) = dayName ifFalse: [firstDay := 1 + (Date dayOfWeek: dayName) - frstDayNdx. firstDay < 1 ifTrue: [firstDay := firstDay + 7]]. ^ firstDay! ! !RuleDate methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! setDayOfWeek: dayName selectionRule: positionName "Private - Set dayOfWeek to dayName, and selectionRule to positionName. Parameters dayName captured positionName captured " dayOfWeek := dayName. selectionRule := positionName! ! !RuleDate methodsFor: 'updating' stamp: 'RAH 4/25/2000 19:49'! updateForYear: yyyy "Update the receiver by applying the rule for its month number of year, yyyy. Definition: Parameters yyyy captured " self basicUpdateForMonth: self monthIndex year: yyyy! ! !RuleDate methodsFor: 'testing' stamp: 'RAH 4/25/2000 19:49'! isRuleDate #DtAndTm. "Added 2000/04/08 To use DNU mod." ^ true! ! !RuleDate commentStamp: '' prior: 0! This class is deprecated. Use the chronology package classes RuleDate instances represent dates determined by some rule (first Tuesday in March, etc.) but the exact day of the month varies from year to year. Once created they must be updated for a selected year to represent the exact day of that year. Typical Use: RuleDate instances are suitable for representing dates such as election day, or the start of daylight saving time in the USA. Implementation: Instance variables: dayOfWeek - a representing the day name of the week (Sunday, etc) of the desired day. selectionRule - a representing the position (first, last) of the desired day in the list of days occurring on that day of the week in the desired month. ! !RuleDate class methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! getValidMonthNumber: monthIn "Private - Answer the month number of monthIn if it is a month name String, else monthIn as the month number if it is an Integer, else signal an error. Definition: Parameters monthIn | captured Return Values new Errors Month is not an Integer 1 - 12. or a valid month name String " monthIn isInteger ifTrue: [(monthIn between: 1 and: 12) ifTrue: [^ monthIn]. ^ Error signal: 'Month must be 1 - 12.']. (monthIn isMemberOf: String) ifTrue: [^ self indexOfMonth: monthIn]. ^ Error signal: 'Month must be an Integer 1 - 12 or a month name String.'! ! !RuleDate class methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! getValidSelectionRule: positionName "Private - Answer the selection position (first, last) in the list of day of the week, Report an error if positionName is not one of (first, last)." | positionSymbol | (positionName isMemberOf: String) ifFalse: [^ Error signal: 'Position name: "' , positionName , '" is not a String.']. positionSymbol := positionName asLowercase asSymbol. (#(first last ) includes: positionSymbol) ifFalse: [^ Error signal: 'Position name: "' , positionName , '" is not valid.']. ^ positionSymbol! ! !RuleDate class methodsFor: 'private' stamp: 'nk 6/2/2004 12:09'! newDayOfWeek: dayName selectionRule: positionName "Private - Answer an uncreated rule date with the dayOfWeek (Sunday, etc) set to dayName, and selectionRule (first, last) set to positionName. Note: Must be updated to create the date. Parameters dayName captured positionName captured Return Values new " | daySymbol newRuleDate positionSymbol | (dayName isMemberOf: String) ifFalse: [^ Error signal: 'Day name: "' , dayName , '" is not a String.']. daySymbol := dayName asLowercase. daySymbol at: 1 put: (daySymbol at: 1) asUppercase. daySymbol := daySymbol asSymbol. (Week dayNames includes: daySymbol) ifFalse: [^ Error signal: 'Day name: "' , dayName , '" is not valid.']. positionSymbol := self getValidSelectionRule: positionName. newRuleDate := super new. newRuleDate setDayOfWeek: daySymbol selectionRule: positionSymbol. ^ newRuleDate! ! !RuleDate class methodsFor: 'deprecated' stamp: 'sd 10/2/2004 11:05'! basicNew self deprecated: 'Do not use this class anymore'. ^ super basicNew! ! !RuleDate class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! first: dayName inMonth: monthIn year: yearIn "Answer a date that is the first day of the week (Sunday, etc), dayName, in month, monthIn, of year, yearIn. Example: RuleDate first: 'Monday' inMonth: 'April' year: 2000 Note: The month may be an index or a month name. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since 1900, or a two digit date from 1900. 1/1/01 will NOT mean 2001. Definition: Parameters dayName captured monthIn | captured yearIn captured Return Values new Errors Day name is not a String and a valid day of the week Month is not an Integer 1 - 12. or a valid month name String " | mmInt newRuleDate | mmInt := self getValidMonthNumber: monthIn. newRuleDate := self newDayOfWeek: dayName selectionRule: 'first'. newRuleDate basicUpdateForMonth: mmInt year: yearIn. ^ newRuleDate! ! !RuleDate class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! last: dayName inMonth: monthIn year: yearIn "Answer a date that is the last day of the week (Sunday, etc), dayName, in month, monthIn, of year, yearIn. Example: RuleDate last: 'Monday' inMonth: 'April' year: 2000 Note: The month may be an index or a month name. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since 1900, or a two digit date from 1900. 1/1/01 will NOT mean 2001. Definition: Parameters dayName captured monthIn | captured yearIn captured Return Values new Errors Day name is not a String and a valid day of the week Month is not an Integer 1 - 12. or a valid month name String " | mmInt newRuleDate | mmInt := self getValidMonthNumber: monthIn. newRuleDate := self newDayOfWeek: dayName selectionRule: 'last'. newRuleDate basicUpdateForMonth: mmInt year: yearIn. ^ newRuleDate! ! !RuleIndexDate methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! applyRuleTo: daysNamedInMonthList "Private - Answer the day of the month selected from dayOfMonth list by applying the receiver's rule." ^ daysNamedInMonthList at: selectionRule! ! !RuleIndexDate commentStamp: '' prior: 0! This class is deprecated. Use the chronology package classes RuleIndexDate instances represent dates determined by some rule but the exact day of the month varies from year to year. Once created they must be updated for a selected year to represent the exact day of that year. It has a rule that selects exact day of the month based on the ordinal position (1, 2, etc.) of the desired day in the list of days occurring on that day of the week in the desired month. Typical Use: RuleIndexDate instances are suitable for representing dates such as Thanksgiving Day (fourth Tuesday in November) in the USA. Implementation: Instance variables: (selectionRule in super class) - an representing the ordinal position (1, 2, etc.) of the desired day in the list of days occurring on that day of the week in the desired month. ! !RuleIndexDate class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! indexed: dayName inMonth: monthIn year: yearIn at: dayListIndex "Answer a date that is at the dayListIndex position of the list of day of the week (Sunday, etc), dayName, in month, monthIn, of year, yearIn. Example: RuleIndexDate indexed: 'Sunday' inMonth: 'April' year: 2000 at: 2. Note: The month may be an index or a month name. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since 1900, or a two digit date from 1900. 1/1/01 will NOT mean 2001. Definition: Parameters dayName captured monthIn | captured yearIn captured dayListIndex captured Return Values new Errors Day name is not a String and a valid day of the week Month is not an Integer 1 - 12. or a valid month name String " | mmInt newRuleDate | mmInt := self getValidMonthNumber: monthIn. newRuleDate := self newDayOfWeek: dayName selectionRule: dayListIndex. newRuleDate basicUpdateForMonth: mmInt year: yearIn. ^ newRuleDate! ! !RuleIndexDate class methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! getValidSelectionRule: dayListIndex "Private - Answer the dayListIndex position in the list of all days named (Sunday, etc) in a month, Report an error if dayListIndex does not represent an ." dayListIndex isInteger ifFalse: [^ self error: 'Not an Integer.']. ^ dayListIndex! ! !RuleIndexDate class methodsFor: 'deprecated' stamp: 'sd 10/2/2004 11:07'! basicNew self deprecated: 'Do not use this class anymore'. ^ super basicNew! ! !RuleSelectionCodeDate methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! applyRuleTo: daysNamedInMonthList "Private - Answer the day of the month selected from dayOfMonth list by applying the receiver's rule." ^ selectionRule value: daysNamedInMonthList! ! !RuleSelectionCodeDate commentStamp: '' prior: 0! This class is deprecated. Use the chronology package classes RuleSelectionCodeDate instances represent dates determined by some rule but the exact day of the month varies from year to year. Once created they must be updated for a selected year to represent the exact day of that year. It has a rule that selects exact day of the month by evaluating the selection block with the list of days occurring on that day of the week in the desired month as an argument. Typical Use: RuleSelectionCodeDate instances are suitable for representing dates such as the last day of daylight saving time (the Saturday before the last Sunday in October) in the USA. Implementation: Instance variables: (selectionRule in super class) - a containing the selection block to be evaluated. The argument is the list of days occurring on that day of the week in the desired month. It must return the desired day of the month which may be any . ! !RuleSelectionCodeDate class methodsFor: 'private' stamp: 'RAH 4/25/2000 19:49'! getValidSelectionRule: selectionBlock "Private - Answer the selectionBlock to select the date given the dayName (Sunday, etc) dayOfMonth list, Report an error if selectionBlock does not represent a block." ((selectionBlock isMemberOf: BlockContext) and: [selectionBlock argumentCount = 1]) ifFalse: [^ self error: 'Not an block.']. ^ selectionBlock! ! !RuleSelectionCodeDate class methodsFor: 'instance creation' stamp: 'RAH 4/25/2000 19:49'! selected: dayName inMonth: monthIn year: yearIn byCode: selectionBlock "Answer a date selected by selectionBlock given the dayName (Sunday, etc) dayOfMonth list, in month, monthIn, of year, yearIn. Example: Standard Time starts on Sunday, so the Daylight Time end is the previous day: RuleSelectionCodeDate selected: 'Sunday' inMonth: 'October' year: 2000 byCode: [ :sundaysList | (sundaysList last) - 1 ]. Note: The selected date need not be in the dayOfMonth list, but may be relative to a named day. The month may be an index or a month name. The year may be specified as the actual number of years since the beginning of the Roman calendar or the number of years since 1900, or a two digit date from 1900. 1/1/01 will NOT mean 2001. Definition: Parameters dayName captured monthIn | captured yearIn captured selectionBlock captured Return Values new Errors Day name is not a String and a valid day of the week Month is not an Integer 1 - 12. or a valid month name String " | mmInt newRuleDate | mmInt := self getValidMonthNumber: monthIn. newRuleDate := self newDayOfWeek: dayName selectionRule: selectionBlock. newRuleDate basicUpdateForMonth: mmInt year: yearIn. ^ newRuleDate! ! !RuleSelectionCodeDate class methodsFor: 'deprecated' stamp: 'sd 10/2/2004 11:07'! basicNew self deprecated: 'Do not use this class anymore'. ^ super basicNew! ! !RulerMorph methodsFor: 'drawing' stamp: 'ar 12/31/2001 02:38'! drawOn: aCanvas | s | super drawOn: aCanvas. s _ self width printString, 'x', self height printString. aCanvas drawString: s in: (bounds insetBy: borderWidth + 5) font: nil color: Color red. ! ! !RulerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:50'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !RulerMorph methodsFor: 'initialization' stamp: 'dgd 3/7/2003 14:50'! defaultColor "answer the default color/fill style for the receiver" ^ Color r: 0.8 g: 1.0 b: 1.0! ! !RulerMorph class methodsFor: 'parts bin' stamp: 'sw 8/2/2001 12:52'! descriptionForPartsBin ^ self partName: 'Ruler' categories: #('Useful') documentation: 'A rectangle which continuously reports its size in pixels'! ! !RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'! first ^values at: 1! ! !RunArray methodsFor: 'accessing' stamp: 'ar 10/16/2001 18:56'! last ^values at: values size! ! !RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'! addFirst: value "Add value as the first element of the receiver." lastIndex _ nil. "flush access cache" (runs size=0 or: [values first ~= value]) ifTrue: [runs _ {1}, runs. values _ {value}, values] ifFalse: [runs at: 1 put: runs first+1]! ! !RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 20:25'! addLast: value "Add value as the last element of the receiver." lastIndex _ nil. "flush access cache" (runs size=0 or: [values last ~= value]) ifTrue: [runs _ runs copyWith: 1. values _ values copyWith: value] ifFalse: [runs at: runs size put: runs last+1]! ! !RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:47'! addLast: value times: times "Add value as the last element of the receiver, the given number of times" times = 0 ifTrue: [ ^self ]. lastIndex _ nil. "flush access cache" (runs size=0 or: [values last ~= value]) ifTrue: [runs _ runs copyWith: times. values _ values copyWith: value] ifFalse: [runs at: runs size put: runs last+times]! ! !RunArray methodsFor: 'adding' stamp: 'BG 6/12/2003 11:07'! rangeOf: attr startingAt: startPos "Answer an interval that gives the range of attr at index position startPos. An empty interval with start value startPos is returned when the attribute attr is not present at position startPos. self size > 0 is assumed, it is the responsibility of the caller to test for emptiness of self. Note that an attribute may span several adjancent runs. " self at: startPos setRunOffsetAndValue: [:run :offset :value | ^(value includes: attr) ifFalse: [startPos to: startPos - 1] ifTrue: [ | firstRelevantPosition lastRelevantPosition idxOfCandidateRun | lastRelevantPosition := startPos - offset + (runs at: run) - 1. firstRelevantPosition := startPos - offset. idxOfCandidateRun := run + 1. [idxOfCandidateRun <= runs size and: [(values at: idxOfCandidateRun) includes: attr]] whileTrue: [lastRelevantPosition := lastRelevantPosition + (runs at: idxOfCandidateRun). idxOfCandidateRun := idxOfCandidateRun + 1]. idxOfCandidateRun := run - 1. [idxOfCandidateRun >= 1 and: [(values at: idxOfCandidateRun) includes: attr]] whileTrue: [firstRelevantPosition := firstRelevantPosition - (runs at: idxOfCandidateRun). idxOfCandidateRun := idxOfCandidateRun - 1]. firstRelevantPosition to: lastRelevantPosition] ]! ! !RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'! repeatLast: times ifEmpty: defaultBlock "add the last value back again, the given number of times. If we are empty, add (defaultBlock value)" times = 0 ifTrue: [^self ]. lastIndex _ nil. "flush access cache" (runs size=0) ifTrue: [runs _ runs copyWith: times. values _ values copyWith: defaultBlock value] ifFalse: [runs at: runs size put: runs last+times] ! ! !RunArray methodsFor: 'adding' stamp: 'ar 10/16/2001 18:48'! repeatLastIfEmpty: defaultBlock "add the last value back again. If we are empty, add (defaultBlock value)" lastIndex _ nil. "flush access cache" (runs size=0) ifTrue:[ runs _ runs copyWith: 1. values _ values copyWith: defaultBlock value] ifFalse: [runs at: runs size put: runs last+1]! ! !RunArray methodsFor: 'copying' stamp: 'ar 10/16/2001 18:57'! , aRunArray "Answer a new RunArray that is a concatenation of the receiver and aRunArray." | new newRuns | (aRunArray isMemberOf: RunArray) ifFalse: [new _ self copy. "attempt to be sociable" aRunArray do: [:each | new addLast: each]. ^new]. runs size = 0 ifTrue: [^aRunArray copy]. aRunArray runs size = 0 ifTrue: [^self copy]. (values at: values size) ~= (aRunArray values at: 1) ifTrue: [^RunArray runs: runs , aRunArray runs values: values , aRunArray values]. newRuns _ runs copyReplaceFrom: runs size to: runs size with: aRunArray runs. newRuns at: runs size put: (runs at: runs size) + (aRunArray runs at: 1). ^RunArray runs: newRuns values: (values copyReplaceFrom: values size to: values size with: aRunArray values)! ! !RunArray methodsFor: 'private' stamp: 'ar 10/16/2001 18:47'! setRuns: newRuns setValues: newValues lastIndex _ nil. "flush access cache" runs _ newRuns asArray. values _ newValues asArray.! ! !RunArray methodsFor: 'enumerating' stamp: 'ar 12/17/2001 00:00'! runsFrom: start to: stop do: aBlock "Evaluate aBlock with all existing runs in the range from start to stop" | run value index | start > stop ifTrue:[^self]. self at: start setRunOffsetAndValue:[:firstRun :offset :firstValue| run _ firstRun. value _ firstValue. index _ start + (runs at: run) - offset. [aBlock value: value. index <= stop] whileTrue:[ run _ run + 1. value _ values at: run. index _ index + (runs at: run)]]. ! ! !RunArray methodsFor: 'converting' stamp: 'BG 6/8/2003 15:17'! reversed ^self class runs: runs reversed values: values reversed! ! !RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:03'! new ^self runs: Array new values: Array new! ! !RunArray class methodsFor: 'instance creation' stamp: 'ar 10/16/2001 19:04'! new: size withAll: value "Answer a new instance of me, whose every element is equal to the argument, value." size = 0 ifTrue: [^self new]. ^self runs: (Array with: size) values: (Array with: value)! ! !RunArray class methodsFor: 'instance creation' stamp: 'nk 9/3/2004 15:12'! scanFrom: strm "Read the style section of a fileOut or sources file. nextChunk has already been done. We need to return a RunArray of TextAttributes of various kinds. These are written by the implementors of writeScanOn:" | rr vv aa this | (strm peekFor: $( ) ifFalse: [^ nil]. rr _ OrderedCollection new. [strm skipSeparators. strm peekFor: $)] whileFalse: [rr add: (Number readFrom: strm)]. vv _ OrderedCollection new. "Value array" aa _ OrderedCollection new. "Attributes list" [(this _ strm next) == nil] whileFalse: [ this == $, ifTrue: [vv add: aa asArray. aa _ OrderedCollection new]. this == $a ifTrue: [aa add: (TextAlignment new alignment: (Integer readFrom: strm))]. this == $f ifTrue: [aa add: (TextFontChange new fontNumber: (Integer readFrom: strm))]. this == $F ifTrue: [aa add: (TextFontReference toFont: (StrikeFont familyName: (strm upTo: $#) size: (Integer readFrom: strm)))]. this == $b ifTrue: [aa add: (TextEmphasis bold)]. this == $i ifTrue: [aa add: (TextEmphasis italic)]. this == $u ifTrue: [aa add: (TextEmphasis underlined)]. this == $= ifTrue: [aa add: (TextEmphasis struckOut)]. this == $n ifTrue: [aa add: (TextEmphasis normal)]. this == $- ifTrue: [aa add: (TextKern kern: -1)]. this == $+ ifTrue: [aa add: (TextKern kern: 1)]. this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color" this == $L ifTrue: [aa add: (TextLink scanFrom: strm)]. "L not look like 1" this == $R ifTrue: [aa add: (TextURL scanFrom: strm)]. "R capitalized so it can follow a number" this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)]. this == $p ifTrue: [aa add: (TextSqkProjectLink scanFrom: strm)]. this == $P ifTrue: [aa add: (TextPrintIt scanFrom: strm)]. this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)]. "space, cr do nothing" ]. aa size > 0 ifTrue: [vv add: aa asArray]. ^ self runs: rr asArray values: vv asArray " RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i') "! ! !RunArrayTest methodsFor: 'testing - instance creation' stamp: 'fbs 4/28/2004 13:24'! testScanFromANSICompatibility RunArray scanFrom: (ReadStream on: '()f1dNumber new;;'). RunArray scanFrom: (ReadStream on: '()a1death;;'). RunArray scanFrom: (ReadStream on: '()F1death;;').! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! directory ^directory! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! directory: anObject directory := anObject! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! fileName ^fileName! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! fileName: anObject fileName := anObject! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:01'! installedMemberNames "Answer the names of the zip members that have been installed already." ^self installedMembers collect: [ :ea | ea fileName ]! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:53'! installedMembers "Answer the zip members that have been installed already." ^installed ifNil: [ installed _ OrderedCollection new ]! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 21:57'! memberNames ^self zip memberNames! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 7/5/2003 23:00'! uninstalledMemberNames "Answer the names of the zip members that have not yet been installed." ^self uninstalledMembers collect: [ :ea | ea fileName ]! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 7/10/2003 16:55'! uninstalledMembers "Answer the zip members that haven't been installed or extracted yet." ^zip members copyWithoutAll: self installedMembers! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! zip ^zip! ! !SARInstaller methodsFor: 'accessing' stamp: 'nk 10/25/2002 12:16'! zip: anObject ^zip := anObject! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'! extractMember: aMemberOrName "Extract aMemberOrName to a file using its filename" (self zip extractMember: aMemberOrName) ifNil: [ self errorNoSuchMember: aMemberOrName ] ifNotNil: [ self installed: aMemberOrName ].! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:25'! extractMember: aMemberOrName toFileNamed: aFileName "Extract aMemberOrName to a specified filename" (self zip extractMember: aMemberOrName toFileNamed: aFileName) ifNil: [ self errorNoSuchMember: aMemberOrName ] ifNotNil: [ self installed: aMemberOrName ].! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'! extractMemberWithoutPath: aMemberOrName "Extract aMemberOrName to its own filename, but ignore any directory paths, using my directory instead." self extractMemberWithoutPath: aMemberOrName inDirectory: self directory. ! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:40'! extractMemberWithoutPath: aMemberOrName inDirectory: aDirectory "Extract aMemberOrName to its own filename, but ignore any directory paths, using aDirectory instead" | member | member _ self memberNamed: aMemberOrName. member ifNil: [ ^self errorNoSuchMember: aMemberOrName ]. self zip extractMemberWithoutPath: member inDirectory: aDirectory. self installed: member.! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 2/13/2004 12:12'! fileInGenieDictionaryNamed: memberName "This is to be used from preamble/postscript code to file in zip members as Genie gesture dictionaries. Answers a dictionary." | member object crDictionary stream | crDictionary _ Smalltalk at: #CRDictionary ifAbsent: [ ^self error: 'Genie not installed' ]. "don't know how to recursively load" member _ self memberNamed: memberName. member ifNil: [ ^self errorNoSuchMember: memberName ]. stream _ ReferenceStream on: member contentStream. [ object _ stream next ] on: Error do: [:ex | stream close. self inform: 'Error on loading: ' , ex description. ^ nil ]. stream close. (object notNil and: [object name isEmptyOrNil]) ifTrue: [object _ crDictionary name: object storedName]. self installed: member. ^ object ! ! !SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:01'! fileInMemberNamed: csName "This is to be used from preamble/postscript code to file in zip members as ChangeSets." | cs | cs _ self memberNamed: csName. cs ifNil: [ ^self errorNoSuchMember: csName ]. self class fileIntoChangeSetNamed: csName fromStream: cs contentStream text setConverterForCode. self installed: cs. ! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 9/20/2003 16:29'! fileInMonticelloPackageNamed: memberName "This is to be used from preamble/postscript code to file in zip members as Monticello packages (.mc)." | member file mcPackagePanel mcRevisionInfo mcSnapshot mcFilePackageManager mcPackage info snapshot newCS mcBootstrap | mcPackagePanel _ Smalltalk at: #MCPackagePanel ifAbsent: [ ]. mcRevisionInfo _ Smalltalk at: #MCRevisionInfo ifAbsent: [ ]. mcSnapshot _ Smalltalk at: #MCSnapshot ifAbsent: [ ]. mcFilePackageManager _ Smalltalk at: #MCFilePackageManager ifAbsent: [ ]. mcPackage _ Smalltalk at: #MCPackage ifAbsent: [ ]. member _ self memberNamed: memberName. member ifNil: [ ^self errorNoSuchMember: memberName ]. "We are missing MCInstaller, Monticello and/or MonticelloCVS. If the bootstrap is present, use it. Otherwise interact with the user." ({ mcPackagePanel. mcRevisionInfo. mcSnapshot. mcFilePackageManager. mcPackage } includes: nil) ifTrue: [ mcBootstrap := self getMCBootstrapLoaderClass. mcBootstrap ifNotNil: [ ^self fileInMCVersion: member withBootstrap: mcBootstrap ]. (self confirm: ('Monticello support is not installed, but must be to load member named ', memberName, '. Load it from SqueakMap?')) ifTrue: [ self class loadMonticello; loadMonticelloCVS. ^self fileInMonticelloPackageNamed: memberName ] ifFalse: [ ^false ] ]. member extractToFileNamed: member localFileName inDirectory: self directory. file _ (Smalltalk at: #MCFile) name: member localFileName directory: self directory. self class withCurrentChangeSetNamed: file name do: [ :cs | newCS _ cs. file readStreamDo: [ :stream | info _ mcRevisionInfo readFrom: stream nextChunk. snapshot _ mcSnapshot fromStream: stream ]. snapshot install. (mcFilePackageManager forPackage: (mcPackage named: info packageName)) file: file ]. newCS isEmpty ifTrue: [ ChangeSorter removeChangeSet: newCS ]. mcPackagePanel allSubInstancesDo: [ :ea | ea refresh ]. World doOneCycle. self installed: member. ! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/10/2003 15:37'! fileInMonticelloVersionNamed: memberName "This is to be used from preamble/postscript code to file in zip members as Monticello version (.mcv) files." | member newCS mcMcvReader | mcMcvReader := Smalltalk at: #MCMcvReader ifAbsent: []. member := self memberNamed: memberName. member ifNil: [^self errorNoSuchMember: memberName]. "If we don't have Monticello, offer to get it." mcMcvReader ifNil: [ (self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '. Load it from SqueakMap?') ifTrue: [ self class loadMonticello. ^self fileInMonticelloVersionNamed: memberName] ifFalse: [^false]]. self class withCurrentChangeSetNamed: member localFileName do: [:cs | newCS := cs. (mcMcvReader versionFromStream: member contentStream ascii) load ]. newCS isEmpty ifTrue: [ChangeSorter removeChangeSet: newCS]. World doOneCycle. self installed: member! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 9/26/2003 15:38'! fileInMonticelloZipVersionNamed: memberName "This is to be used from preamble/postscript code to file in zip members as Monticello version (.mcz) files." | member mczInstaller newCS mcMczReader | mcMczReader := Smalltalk at: #MCMczReader ifAbsent: []. mczInstaller := Smalltalk at: #MczInstaller ifAbsent: []. member := self memberNamed: memberName. member ifNil: [^self errorNoSuchMember: memberName]. "If we don't have Monticello, but have the bootstrap, use it silently." mcMczReader ifNil: [ mczInstaller ifNotNil: [ ^mczInstaller installStream: member contentStream ]. (self confirm: 'Monticello is not installed, but must be to load member named ', memberName , '. Load it from SqueakMap?') ifTrue: [ self class loadMonticello. ^self fileInMonticelloZipVersionNamed: memberName] ifFalse: [^false]]. self class withCurrentChangeSetNamed: member localFileName do: [:cs | newCS := cs. (mcMczReader versionFromStream: member contentStream) load ]. newCS isEmpty ifTrue: [ChangeSorter removeChangeSet: newCS]. World doOneCycle. self installed: member! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:27'! fileInMorphsNamed: memberName addToWorld: aBoolean "This will load the Morph (or Morphs) from the given member. Answers a Morph, or a list of Morphs, or nil if no such member or error. If aBoolean is true, also adds them and their models to the World." | member morphOrList | member _ self memberNamed: memberName. member ifNil: [ ^self errorNoSuchMember: memberName ]. self installed: member. morphOrList _ member contentStream fileInObjectAndCode. morphOrList ifNil: [ ^nil ]. aBoolean ifTrue: [ ActiveWorld addMorphsAndModel: morphOrList ]. ^morphOrList ! ! !SARInstaller methodsFor: 'client services' stamp: 'yo 8/17/2004 10:05'! fileInPackageNamed: memberName "This is to be used from preamble/postscript code to file in zip members as DVS packages." | member current new baseName imagePackageLoader packageInfo streamPackageLoader packageManager | member _ self zip memberNamed: memberName. member ifNil: [ ^self errorNoSuchMember: memberName ]. imagePackageLoader _ Smalltalk at: #ImagePackageLoader ifAbsent: []. streamPackageLoader _ Smalltalk at: #StreamPackageLoader ifAbsent: []. packageInfo _ Smalltalk at: #PackageInfo ifAbsent: []. packageManager _ Smalltalk at: #FilePackageManager ifAbsent: []. "If DVS isn't present, do a simple file-in" (packageInfo isNil or: [imagePackageLoader isNil or: [streamPackageLoader isNil]]) ifTrue: [ ^ self fileInMemberNamed: memberName ]. baseName _ memberName copyReplaceAll: '.st' with: '' asTokens: false. (packageManager allManagers anySatisfy: [ :pm | pm packageName = baseName ]) ifTrue: [ current _ imagePackageLoader new package: (packageInfo named: baseName). new _ streamPackageLoader new stream: member contentStream ascii. (new changesFromBase: current) fileIn ] ifFalse: [ self class fileIntoChangeSetNamed: baseName fromStream: member contentStream ascii setConverterForCode. ]. packageManager registerPackage: baseName. self installed: member.! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/27/2003 09:49'! fileInProjectNamed: projectOrMemberName createView: aBoolean "This is to be used from preamble/postscript code to file in SAR members as Projects. Answers the loaded project, or nil. Does not enter the loaded project. If aBoolean is true, also creates a ProjectViewMorph (possibly in a window, depending on your Preferences)." | member project triple memberName | member _ self memberNamed: projectOrMemberName. member ifNotNil: [ memberName _ member fileName ] ifNil: [ member _ self memberNamed: (memberName _ self memberNameForProjectNamed: projectOrMemberName) ]. member ifNil: [ ^self errorNoSuchMember: projectOrMemberName ]. triple _ Project parseProjectFileName: memberName unescapePercents. project _ nil. [[ProjectLoading openName: triple first stream: member contentStream fromDirectory: nil withProjectView: nil] on: ProjectViewOpenNotification do: [:ex | ex resume: aBoolean]] on: ProjectEntryNotification do: [:ex | project _ ex projectToEnter. ex resume]. self installed: member. ^ project! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 9/26/2003 17:17'! fileInTrueTypeFontNamed: memberOrName | member description | member := self memberNamed: memberOrName. member ifNil: [^self errorNoSuchMember: memberOrName]. description _ TTFontDescription addFromTTStream: member contentStream. TTCFont newTextStyleFromTT: description. World doOneCycle. self installed: member! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 9/9/2003 11:56'! getMCBootstrapLoaderClass ^Smalltalk at: #MCBootstrapLoader ifAbsent: [(self memberNamed: 'MCBootstrapLoader.st') ifNotNilDo: [:m | self fileInMemberNamed: m. Smalltalk at: #MCBootstrapLoader ifAbsent: []]]! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 15:40'! importImage: memberOrName | member form | member _ self memberNamed: memberOrName. member ifNil: [ ^self errorNoSuchMember: memberOrName ]. form _ ImageReadWriter formFromStream: member contentStream binary. form ifNil: [ ^self ]. Imports default importImage: form named: (FileDirectory localNameFor: member fileName) sansPeriodSuffix. self installed: member.! ! !SARInstaller methodsFor: 'client services' stamp: 'tak 1/24/2005 19:12'! installMember: memberOrName | memberName extension isGraphic stream member | member _ self memberNamed: memberOrName. member ifNil: [ ^false ]. memberName _ member fileName. extension _ (FileDirectory extensionFor: memberName) asLowercase. Smalltalk at: #CRDictionary ifPresent: [ :crDictionary | (extension = crDictionary fileNameSuffix) ifTrue: [ self fileInGenieDictionaryNamed: memberName. ^true ] ]. extension caseOf: { [ Project projectExtension ] -> [ self fileInProjectNamed: memberName createView: true ]. [ FileStream st ] -> [ self fileInPackageNamed: memberName ]. [ FileStream cs ] -> [ self fileInMemberNamed: memberName ]. " [ FileStream multiSt ] -> [ self fileInMemberNamedAsUTF8: memberName ]. [ FileStream multiCs ] -> [ self fileInMemberNamedAsUTF8: memberName ]. " [ 'mc' ] -> [ self fileInMonticelloPackageNamed: memberName ]. [ 'mcv' ] -> [ self fileInMonticelloVersionNamed: memberName ]. [ 'mcz' ] -> [ self fileInMonticelloZipVersionNamed: memberName ]. [ 'morph' ] -> [ self fileInMorphsNamed: member addToWorld: true ]. [ 'ttf' ] -> [ self fileInTrueTypeFontNamed: memberName ]. [ 'translation' ] -> [ self fileInMemberNamed: memberName ]. } otherwise: [ ('t*xt' match: extension) ifTrue: [ self openTextFile: memberName ] ifFalse: [ stream _ member contentStream. isGraphic _ ImageReadWriter understandsImageFormat: stream. stream reset. isGraphic ifTrue: [ self openGraphicsFile: member ] ifFalse: [ "now what?" ^false ]] ]. ^true ! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 10:02'! memberNameForProjectNamed: projectName "Answer my member name for the given project, or nil. Ignores version numbers and suffixes, and also unescapes percents in filenames." ^self zip memberNames detect: [ :memberName | | triple | triple _ Project parseProjectFileName: memberName unescapePercents. triple first asLowercase = projectName asLowercase ] ifNone: [ nil ].! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/14/2003 18:58'! memberNamed: aString ^(zip member: aString) ifNil: [ | matching | matching _ zip membersMatching: aString. matching isEmpty ifFalse: [ matching last ]].! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:34'! membersMatching: aString ^self zip membersMatching: aString! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 6/12/2004 10:03'! openGraphicsFile: memberOrName | member morph | member _ self memberNamed: memberOrName. member ifNil: [ ^self errorNoSuchMember: memberOrName ]. morph _ (World drawingClass fromStream: member contentStream binary). morph ifNotNil: [ morph openInWorld ]. self installed: member.! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 7/5/2003 22:28'! openTextFile: memberOrName "Open a text window on the given member" | member | member _ self memberNamed: memberOrName. member ifNil: [ ^self errorNoSuchMember: memberOrName ]. StringHolder new acceptContents: member contents; openLabel: member fileName. self installed: member.! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:36'! prependedDataSize ^self zip prependedDataSize! ! !SARInstaller methodsFor: 'client services' stamp: 'nk 10/27/2002 10:35'! zipFileComment ^self zip zipFileComment! ! !SARInstaller methodsFor: 'fileIn' stamp: 'nk 7/27/2003 13:52'! fileIn "File in to a change set named like my file" | stream newCS | stream := directory readOnlyFileNamed: fileName. self class withCurrentChangeSetNamed: fileName do: [:cs | newCS _ cs. self fileInFrom: stream]. newCS isEmpty ifTrue: [ ChangeSorter removeChangeSet: newCS ]! ! !SARInstaller methodsFor: 'fileIn' stamp: 'yo 8/17/2004 00:33'! fileInFrom: stream "The zip has been saved already by the download. Read the zip into my instvar, then file in the correct members" | preamble postscript | [ stream position: 0. zip _ ZipArchive new readFrom: stream. preamble _ zip memberNamed: 'install/preamble'. preamble ifNotNil: [ preamble contentStream text setConverterForCode fileInFor: self announcing: 'Preamble'. self class currentChangeSet preambleString: preamble contents. ]. postscript _ zip memberNamed: 'install/postscript'. postscript ifNotNil: [ postscript contentStream text setConverterForCode fileInFor: self announcing: 'Postscript'. self class currentChangeSet postscriptString: postscript contents. ]. preamble isNil & postscript isNil ifTrue: [ (self confirm: 'No install/preamble or install/postscript member were found. Install all the members automatically?') ifTrue: [ self installAllMembers ] ]. ] ensure: [ stream close ]. ! ! !SARInstaller methodsFor: 'fileIn' stamp: 'nk 7/27/2003 14:02'! fileIntoChangeSetNamed: aString fromStream: stream "Not recommended for new code" ^self class fileIntoChangeSetNamed: aString fromStream: stream! ! !SARInstaller methodsFor: 'fileIn' stamp: 'nk 10/12/2003 20:41'! installAllMembers "Try to install all the members, in order, based on their filenames and/or contents." | uninstalled | uninstalled _ OrderedCollection new. zip members do: [ :member | self installMember: member ]. uninstalled _ self uninstalledMembers. uninstalled isEmpty ifTrue: [ ^self ]. uninstalled inspect.! ! !SARInstaller methodsFor: 'private' stamp: 'nk 10/13/2003 12:56'! errorNoSuchMember: aMemberName (self confirm: 'No member named ', aMemberName, '. Do you want to stop loading?') == true ifTrue: [ self error: 'aborted' ].! ! !SARInstaller methodsFor: 'private' stamp: 'nk 9/9/2003 12:25'! fileInMCVersion: member withBootstrap: mcBootstrap "This will use the MCBootstrapLoader to load a (non-compressed) Monticello file (.mc or .mcv)" | newCS | self class withCurrentChangeSetNamed: member localFileName do: [ :cs | newCS _ cs. mcBootstrap loadStream: member contentStream ascii ]. newCS isEmpty ifTrue: [ ChangeSorter removeChangeSet: newCS ]. World doOneCycle. self installed: member.! ! !SARInstaller methodsFor: 'private' stamp: 'nk 7/10/2003 16:55'! installed: aMemberOrName self installedMembers add: (self zip member: aMemberOrName)! ! !SARInstaller methodsFor: 'initialization' stamp: 'nk 7/5/2003 22:24'! initialize installed _ OrderedCollection new.! ! !SARInstaller commentStamp: 'nk 7/5/2003 21:12' prior: 0! I am an object that handles the loading of SAR (Squeak ARchive) files. A SAR file is a Zip file that follows certain simple conventions: * it may have a member named "install/preamble". This member, if present, will be filed in as Smalltalk source code at the beginning of installation. Typically, the code in the preamble will make whatever installation preparations are necessary, and will then call methods in the "client services" method category to extract or install other zip members. * It may have a member named "install/postscript". This member, if present, will be filed in as Smalltalk source code at the end of installation. Typically, the code in the postscript will set up the operating environment, and will perhaps put objects in flaps, open projects or README files, or launch samples. Within the code in the preamble and postscript, "self" is set to the instance of the SARInstaller. If neither an "install/preamble" nor an "install/postscript" file is present, all the members will be installed after prompting the user, based on a best guess of the member file types that is based on member filename extensions. This is new behavior.! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/13/2002 07:33'! fileReaderServicesForFile: fullName suffix: suffix ^(suffix = 'sar') | (suffix = '*') ifTrue: [Array with: self serviceFileInSAR] ifFalse: [#()] ! ! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 22:22'! initialize "SARInstaller initialize" (FileList respondsTo: #registerFileReader:) ifTrue: [ FileList registerFileReader: self ]! ! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 21:05'! installSAR: relativeOrFullName FileDirectory splitName: (FileDirectory default fullNameFor: relativeOrFullName) to: [ :dir :fileName | (self directory: (FileDirectory on: dir) fileName: fileName) fileIn ]! ! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/13/2002 07:35'! serviceFileInSAR "Answer a service for opening a changelist browser on a file" ^ SimpleServiceEntry provider: self label: 'install SAR' selector: #installSAR: description: 'install this Squeak ARchive into the image.' buttonLabel: 'install'! ! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 11/21/2002 09:46'! services ^Array with: self serviceFileInSAR ! ! !SARInstaller class methodsFor: 'class initialization' stamp: 'nk 7/5/2003 22:22'! unload (FileList respondsTo: #unregisterFileReader:) ifTrue: [ FileList unregisterFileReader: self ]! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'! basicNewChangeSet: newName Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs basicNewChangeSet: newName ]. (self changeSetNamed: newName) ifNotNil: [ self inform: 'Sorry that name is already used'. ^nil ]. ^ChangeSet basicNewNamed: newName.! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 10/27/2002 12:44'! changeSetNamed: newName Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs changeSetNamed: newName ]. ^ChangeSet allInstances detect: [ :cs | cs name = newName ] ifNone: [ nil ].! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:49'! currentChangeSet "Answer the current change set, in a way that should work in 3.5 as well" "SARInstaller currentChangeSet" ^[ ChangeSet current ] on: MessageNotUnderstood do: [ :ex | ex return: Smalltalk changes ]! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'yo 8/17/2004 10:04'! fileIntoChangeSetNamed: aString fromStream: stream "We let the user confirm filing into an existing ChangeSet or specify another ChangeSet name if the name derived from the filename already exists. Duplicated from SMSimpleInstaller. Should be a class-side method." ^self withCurrentChangeSetNamed: aString do: [ :cs | | newName | newName := cs name. stream setConverterForCode. stream fileInAnnouncing: 'Loading ' , newName , ' into change set ''' , newName, ''''. stream close]! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:51'! newChanges: aChangeSet "Change the current change set, in a way that should work in 3.5 as well" "SARInstaller newChanges: SARInstaller currentChangeSet" ^[ ChangeSet newChanges: aChangeSet ] on: MessageNotUnderstood do: [ :ex | ex return: (Smalltalk newChanges: aChangeSet) ]! ! !SARInstaller class methodsFor: 'change set utilities' stamp: 'nk 7/5/2003 22:56'! withCurrentChangeSetNamed: aString do: aOneArgumentBlock "Evaluate the one-argument block aOneArgumentBlock while the named change set is active. We let the user confirm operating on an existing ChangeSet or specify another ChangeSet name if the name derived from the filename already exists. Duplicated from SMSimpleInstaller. Returns change set." | changeSet newName oldChanges | newName := aString. changeSet := self changeSetNamed: newName. changeSet ifNotNil: [newName := FillInTheBlank request: 'ChangeSet already present, just confirm to overwrite or enter a new name:' initialAnswer: newName. newName isEmpty ifTrue: [self error: 'Cancelled by user']. changeSet := self changeSetNamed: newName]. changeSet ifNil: [changeSet := self basicNewChangeSet: newName]. changeSet ifNil: [self error: 'User did not specify a valid ChangeSet name']. oldChanges := self currentChangeSet. [ self newChanges: changeSet. aOneArgumentBlock value: changeSet] ensure: [ self newChanges: oldChanges]. ^changeSet! ! !SARInstaller class methodsFor: 'instance creation' stamp: 'nk 10/27/2002 10:29'! directory: dir fileName: fn ^(self new) directory: dir; fileName: fn; yourself.! ! !SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:21'! cardForSqueakMap: aSqueakMap "Answer the current card or a new card." (aSqueakMap cardWithId: self squeakMapPackageID) ifNotNilDo: [ :card | (card installedVersion = self squeakMapPackageVersion) ifTrue: [ ^card ] ]. ^self newCardForSqueakMap: aSqueakMap ! ! !SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:17'! newCardForSqueakMap: aSqueakMap "Answer a new card." ^(aSqueakMap newCardWithId: self squeakMapPackageID) created: 3236292323 updated:3236292323 name: 'SARInstaller for 3.6' currentVersion:'16' summary: 'Lets you load SAR (Squeak ARchive) files from SqueakMap and the File List. For 3.6 and later images.' description:'Support for installing SAR (Squeak ARchive) packages from SqueakMap and the File List. For 3.6 and later images. SMSARInstaller will use this if it''s present to load SAR packages. Use SARBuilder for making these packages easily.' url: 'http://bike-nomad.com/squeak/' downloadUrl:'http://bike-nomad.com/squeak/SARInstallerFor36-nk.16.cs.gz' author: 'Ned Konz ' maintainer:'Ned Konz ' registrator:'Ned Konz ' password:240495131608326995113451940367316491071470713347 categories: #('6ba57b6e-946a-4009-beaa-0ac93c08c5d1' '94277ca9-4d8f-4f0e-a0cb-57f4b48f1c8a' 'a71a6233-c7a5-4146-b5e3-30f28e4d3f6b' '8209da9b-8d6e-40dd-b23a-eb7e05d4677b' ); modulePath: '' moduleVersion:'' moduleTag:'' versionComment:'v16: same as v16 of SARInstaller for 3.4 but doesn''t include any classes other than SARInstaller. To be loaded into 3.6 images only. Will de-register the 3.4 version if it''s registered. Added a default (DWIM) mode in which SAR files that are missing both a preamble and postscript have all their members loaded in a default manner. Changed the behavior of #extractMemberWithoutPath: to use the same directory as the SAR itself. Added #extractMemberWithoutPath:inDirectory: Moved several change set methods to the class side. Made change set methods work with 3.5 or 3.6a/b Now supports the following file types: Projects (with or without construction of a ViewMorph) Genie gesture dictionaries Change sets DVS packages Monticello packages Graphics files (loaded as SketchMorphs) Text files (loaded as text editor windows) Morph(s) in files Now keeps track of installed members.'! ! !SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:16'! squeakMapPackageID ^'75c970ab-dca7-48ee-af42-5a013912c880'! ! !SARInstaller class methodsFor: 'SqueakMap' stamp: 'nk 7/21/2003 17:18'! squeakMapPackageVersion ^'16'! ! !SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 16:18'! ensurePackageWithId: anIdString self squeakMapDo: [ :sm | | card newCS | self withCurrentChangeSetNamed: 'updates' do: [ :cs | newCS _ cs. card _ sm cardWithId: anIdString. (card isNil or: [ card isInstalled not or: [ card isOld ]]) ifTrue: [ sm installPackageWithId: anIdString ] ]. newCS isEmpty ifTrue: [ ChangeSorter removeChangeSet: newCS ] ].! ! !SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:05'! loadDVS "Load the DVS support from SqueakMap" self ensurePackageWithId: '100d59d0-bf81-4e74-a4fe-5a2fd0c6b4ec'! ! !SARInstaller class methodsFor: 'package format support' stamp: 'nk 9/9/2003 12:08'! loadMonticello "Load Monticello support (MCInstaller and Monticello) from SqueakMap" self ensurePackageWithId: 'af9d090d-2896-4a4e-82d0-c61cf2fdf40e'. self ensurePackageWithId: '66236497-7026-45f5-bcf6-ad00ba7a8a4e'.! ! !SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 14:39'! loadMonticelloCVS "Load MonticelloCVS support from SqueakMap" self ensurePackageWithId: '2be9f7e2-1de2-4eb6-89bd-ec9b60593a93'. ! ! !SARInstaller class methodsFor: 'package format support' stamp: 'nk 7/25/2003 08:27'! squeakMapDo: aBlock "If SqueakMap is installed, evaluate aBlock with the default map. Otherwise, offer to install SqueakMap and continue." Smalltalk at: #SMSqueakMap ifPresent: [ :smClass | ^aBlock value: smClass default ]. (self confirm: 'SqueakMap is not installed in this image. Would you like to load it from the network?') ifTrue: [ TheWorldMenu loadSqueakMap. ^self squeakMapDo: aBlock ]. ^nil! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 11/13/2003 23:06'! advogatoId ^advogatoId! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 11/13/2003 23:05'! advogatoId: aString advogatoId _ aString! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 6/26/2003 14:26'! email ^email! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 6/26/2003 14:27'! email: address email _ address! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 7/30/2003 14:10'! initials ^initials! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/8/2003 19:11'! initials: aString "If these are changed we need to update the dictionary in the map." initials ~= aString ifTrue: [ initials _ aString. map clearUsernames]! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 11/17/2003 11:49'! isAdmin ^isAdmin ifNil: [false] ifNotNil: [isAdmin]! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 11/17/2003 11:47'! isAdmin: aBoolean isAdmin _ aBoolean! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 7/9/2004 20:06'! nameAndEmail ^name , ' <', email, '>'! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 16:34'! newPassword "Get the parallell password hash." ^newPassword! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:16'! newPassword: aHashNumber "Set the parallell password hash." newPassword _ aHashNumber! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:42'! password "Get the password hash." ^password! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 11:51'! password: aHashNumber "Set the password hash." password _ aHashNumber! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:56'! signature "Get the signature." ^signature! ! !SMAccount methodsFor: 'accessing' stamp: 'gk 8/4/2003 15:57'! signature: aSignature "Set the signature." signature _ aSignature! ! !SMAccount methodsFor: 'printing' stamp: 'gk 11/14/2003 00:12'! type ^'Account'! ! !SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 16:16'! addCoObject: anObject "Add to this account. Only called from #addMaintainer:." (coObjects includes: anObject) ifFalse:[coObjects add: anObject]! ! !SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 20:49'! addObject: anObject "Add to this account. Also makes sure the reverse reference is correct." (objects includes: anObject) ifFalse:[ objects add: anObject. anObject owner: self. map addObject: anObject]! ! !SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 17:37'! coPackageWithId: anIdString "Return the correct package or nil." | uuid | uuid _ UUID fromString: anIdString. ^self coPackages detect: [:p | p id = uuid ] ifNone: [nil]! ! !SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 16:13'! coPackages "Return all co-maintained packages." ^coObjects select: [:o | o isPackage].! ! !SMAccount methodsFor: 'objects' stamp: 'gk 8/7/2003 21:00'! moveObject: aPersonalObject toAccount: anAccount "Transfer the ownership of the given personal object to ." self removeObject: aPersonalObject. anAccount addObject: aPersonalObject! ! !SMAccount methodsFor: 'objects' stamp: 'gk 8/7/2003 02:50'! packageWithId: anIdString "Return the correct package or nil." | uuid | uuid _ UUID fromString: anIdString. ^self packages detect: [:p | p id = uuid ] ifNone: [nil]! ! !SMAccount methodsFor: 'objects' stamp: 'gk 8/4/2003 13:58'! packages "Return all owned packages." ^objects select: [:o | o isPackage].! ! !SMAccount methodsFor: 'objects' stamp: 'gk 11/11/2003 16:16'! removeCoObject: anObject "Remove from this account. Only called from #removeMaintainer:." (coObjects includes: anObject) ifTrue: [ coObjects remove: anObject]! ! !SMAccount methodsFor: 'objects' stamp: 'gk 8/7/2003 20:56'! removeObject: anObject "Remove from this account. Also makes sure the reverse reference is cleared." (objects includes: anObject) ifTrue: [ anObject owner: nil. objects remove: anObject]! ! !SMAccount methodsFor: 'passwords' stamp: 'gk 8/4/2003 14:50'! correctPassword: aPassword "We store the password as a SHA hash so that we can let the slave maps have them too. Also check the optional new random password." | try | aPassword isEmptyOrNil ifTrue:[^false]. try _ SecureHashAlgorithm new hashMessage: aPassword. ^password = try or: [newPassword = try]! ! !SMAccount methodsFor: 'passwords' stamp: 'gk 11/17/2003 10:22'! createRandomPassword | randomPass | randomPass _ String streamContents: [:stream | 10 timesRepeat: [ stream nextPut: 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' atRandom]]. self setNewPassword: randomPass. ^randomPass! ! !SMAccount methodsFor: 'passwords' stamp: 'gk 6/26/2003 14:02'! setNewPassword: aString "Set a new parallell password the user can use to get in if the old password is forgotten. We don't delete the old password since the request for this new password is made anonymously. Note that the password is stored as a secured hash large integer." newPassword _ SecureHashAlgorithm new hashMessage: aString! ! !SMAccount methodsFor: 'passwords' stamp: 'gk 6/26/2003 13:58'! setPassword: aString "We also clear the random extra password." password _ SecureHashAlgorithm new hashMessage: aString. newPassword _ nil! ! !SMAccount methodsFor: 'view' stamp: 'gk 11/12/2003 14:14'! getLink: aBuilder "Return a link for using on the web." ^aBuilder getLinkLocal: '/accountbyid/', id asString text: self nameWithInitials! ! !SMAccount methodsFor: 'view' stamp: 'gk 8/4/2003 14:10'! logout "Automatically called upon logout. Do nothing."! ! !SMAccount methodsFor: 'view' stamp: 'gk 8/5/2003 13:16'! nameWithInitials "Return name and developer initials within parentheses." ^name, ' (', (initials isEmptyOrNil ifTrue: ['not entered'] ifFalse: [initials]) , ')'! ! !SMAccount methodsFor: 'view' stamp: 'gk 8/8/2003 00:09'! publicViewFor: uiObject "This is a double dispatch mechanism for multiple views for multiple uis." ^uiObject publicAccountViewOn: self! ! !SMAccount methodsFor: 'view' stamp: 'gk 6/26/2003 16:01'! viewFor: uiObject "This is a double dispatch mechanism for multiple views for multiple uis." ^uiObject accountViewOn: self! ! !SMAccount methodsFor: 'files' stamp: 'gk 3/8/2004 19:26'! delete "Delete this account. First delete all SM objects we own and disconnect this account from those we co-maintain." objects do: [:o | o delete]. coObjects do: [:co | co removeMaintainer: self]. super delete ! ! !SMAccount methodsFor: 'files' stamp: 'gk 3/8/2004 19:26'! deleteFiles: fileNames "Delete all fileNames from the uploads directory." | dir | dir _ self uploadsDirectory. fileNames do: [:fn | dir deleteFileNamed: fn] ! ! !SMAccount methodsFor: 'files' stamp: 'gk 8/14/2003 14:39'! directory "Get the directory for the account." | dir | dir _ (map directory directoryNamed: 'accounts') assureExistence; yourself. ^(dir directoryNamed: id asString) assureExistence; yourself ! ! !SMAccount methodsFor: 'files' stamp: 'gk 3/8/2004 19:26'! entries "Return all file entries in the upload directory." ^self uploadsDirectory entries! ! !SMAccount methodsFor: 'files' stamp: 'gk 8/15/2003 12:08'! files "Return filenames for uploaded files." ^self uploadsDirectory fileNames ! ! !SMAccount methodsFor: 'files' stamp: 'gk 9/23/2003 21:16'! newFile: fileName block: aBlock "Create a new file. Let fill the file with content by calling it with a stream." | dir stream | dir _ self uploadsDirectory. [(dir fileExists: fileName) ifTrue:[dir deleteFileNamed: fileName]. stream _ dir newFileNamed: fileName. aBlock value: stream] ensure: [stream close]! ! !SMAccount methodsFor: 'files' stamp: 'gk 8/14/2003 14:28'! streamForFile: fileName "Return a readonly stream for file . If the file does not exist return nil." | stream | [stream _ self uploadsDirectory oldFileNamed: fileName] on: FileDoesNotExistException do: [^nil]. ^stream! ! !SMAccount methodsFor: 'files' stamp: 'gk 8/14/2003 14:23'! uploadsDirectory "Get the directory for uploaded files, create it if missing." ^(self directory directoryNamed: 'uploads') assureExistence; yourself ! ! !SMAccount methodsFor: 'testing' stamp: 'gk 6/26/2003 16:47'! isAccount ^true! ! !SMAccount methodsFor: 'testing' stamp: 'gk 11/11/2003 17:24'! owns: anObject ^objects includes: anObject! ! !SMAccount methodsFor: 'initialize-release' stamp: 'gk 11/17/2003 11:49'! initialize "Initialize account." super initialize. initials _ signature _ advogatoId _ ''. isAdmin _ false. objects _ OrderedCollection new. coObjects _ OrderedCollection new! ! !SMAccount commentStamp: 'gk 3/8/2004 19:29' prior: 0! SMAccount is the object representing a user account in SqueakMap. It keeps track of the email address, developer initials and two passwords used to access the account. There is also an advogatoId (people.squeakfoundation.org username) and a signature field (not used yet). The flag isAdmin is a crude way of marking a user as a superuser, this will possibly be changed in the future and instead expressed using a category. Passwords are stored as secure hashes. The extra password (newPassword) is used when the regular password is forgotten - it is then randomly set and an email is sent out containing it to the registered email. This enables the original password to still work. When logging in, the user gets a chance to enter a new regular password overwriting the old one and clearing the random new password in the process. The instvar objects holds all SMPersonalObjects that this account "owns" - these are typically instances of SMPackages and SMResources, but are not limited to be. The instvar coObjects holds all SMPersonalObjects that this account is co-maintaining - these are typically instances of SMPackages and SMResources. Finally the account also maintains a directory with uploaded files on the server. This directory has the UUID of the account as its name and it located under sm/accounts! !SMCategorizableObject methodsFor: 'categories' stamp: 'gk 9/23/2003 20:45'! categoriesDo: aBlock "Evaluate aBlock for each of the categories." categories ifNil: [^self]. categories do: aBlock! ! !SMCategorizableObject methodsFor: 'categories' stamp: 'gh 11/27/2002 12:35'! categoryForParent: aCategory "Answer the one of my categories with parent , if I have it." categories ifNil: [^nil]. ^categories detect: [:cat | cat parent = aCategory ] ifNone: [nil]! ! !SMCategorizableObject methodsFor: 'categories' stamp: 'gh 11/27/2002 12:35'! hasCategory: aCategory "Answer true if I am in it." ^categories notNil and: [categories includes: aCategory]! ! !SMCategorizableObject methodsFor: 'categories' stamp: 'gk 7/9/2004 02:57'! hasCategoryOrSubCategoryOf: aCategory "Answer true if I am in aCategory or if I am in any of its sub categories recursively." aCategory allCategoriesDo: [:cat | (self hasCategory: cat) ifTrue: [^ true]]. ^false! ! !SMCategorizableObject methodsFor: 'private' stamp: 'gh 11/27/2002 12:35'! addCategory: aCategory "Add to me. If I already have it do nothing." categories ifNil: [categories _ OrderedCollection new]. (categories includes: aCategory) ifFalse:[ aCategory addObject: self. categories add: aCategory]. ^aCategory! ! !SMCategorizableObject methodsFor: 'private' stamp: 'gk 8/8/2003 02:35'! delete "Delete me. Disconnect me from my categories." super delete. self removeFromCategories! ! !SMCategorizableObject methodsFor: 'private' stamp: 'gh 11/27/2002 12:35'! removeCategory: aCategory "Remove category from me if I am in it." (categories notNil and: [categories includes: aCategory]) ifTrue:[ aCategory removeObject: self. categories remove: aCategory]. ^aCategory! ! !SMCategorizableObject methodsFor: 'private' stamp: 'gh 11/27/2002 12:35'! removeFromCategories "Remove me from all my categories." categories ifNotNil:[ categories copy do: [:cat | self removeCategory: cat ]]! ! !SMCategorizableObject methodsFor: 'initialize-release' stamp: 'gk 9/23/2003 20:44'! categories: anArray "Method used when recreating the object in the image when we need to bind the category ids with the actual category objects." anArray do: [:i | self addCategory: (map categoryWithId: i)]! ! !SMCategorizableObject methodsFor: 'accessing' stamp: 'gk 9/23/2003 20:44'! categories "Lazily initialized." ^categories ifNil: [OrderedCollection new]! ! !SMCategorizableObject methodsFor: 'printing' stamp: 'dew 3/17/2004 16:28'! describeCategoriesOn: aStream indent: tabs "Show a full listing of categories and their dscription on aStream, indented by the given number of tabs." categories isEmptyOrNil ifFalse: [aStream cr; withAttribute: TextEmphasis bold do: [aStream nextPutAll: 'Categories: ']; cr. (self categories asSortedCollection: [:a :b | a path < b path]) do: [:c | aStream tab: tabs. c parentsDo: [:p | aStream nextPutAll: p name; nextPut: $/]. aStream nextPutAll: c name; nextPutAll: ' - '; withAttributes: {TextEmphasis italic. TextIndent tabs: tabs + 1 } do: [aStream nextPutAll: c summary]; cr]]! ! !SMCategorizableObject commentStamp: 'gk 3/8/2004 19:36' prior: 0! A categorizable object can be associated with one or more SMCategories. The relation between the categories and the SMCategorizableObject is bidirectional. A categorizable object can also have attached resources, SMResource. The categories are used to classify the categorizable object for different purposes. Package and package releases are classified in different ways, but so can resources and accounts be. Accounts can be given various roles using categories.! !SMCategory methodsFor: 'services' stamp: 'gk 11/17/2003 10:48'! allCategoriesDo: aBlock "Evaluate for all categories below me including me, bottom up breadth-first." self allSubCategoriesDo: aBlock. aBlock value: self! ! !SMCategory methodsFor: 'services' stamp: 'gk 7/9/2004 02:59'! allSubCategoriesDo: aBlock "Evaluate for all categories below me NOT including me, bottom up breadth-first." subCategories ifNil: [^self]. subCategories do: [:sub | sub allSubCategoriesDo: aBlock. aBlock value: sub]! ! !SMCategory methodsFor: 'services' stamp: 'gh 8/5/2002 17:10'! categoryBefore "Return the category listed before me in my parent. If I am first or I have no parent, return nil." parent isNil ifTrue:[^nil]. parent subCategories first = self ifTrue:[^nil]. ^parent subCategories before: self ! ! !SMCategory methodsFor: 'services' stamp: 'gh 8/5/2002 14:36'! move: cat toAfter: before "Move a category to be after the category ." subCategories remove: cat. before ifNil: [subCategories addFirst: cat] ifNotNil: [subCategories add: cat after: before]! ! !SMCategory methodsFor: 'services' stamp: 'gh 8/1/2002 17:30'! parentsDo: aBlock "Run a block for all my parents starting from the top." parent ifNotNil: [ parent parentsDo: aBlock. aBlock value: parent]! ! !SMCategory methodsFor: 'services' stamp: 'gh 6/27/2002 16:20'! removeCategory: cat "Remove a category from subcategories of self. No error handling is done here." cat parent: nil. ^subCategories remove: cat! ! !SMCategory methodsFor: 'services' stamp: 'gk 3/8/2004 19:48'! removeMandatoryClass: aClass "Remove as one of the SMObject types that I am mandatory for." mandatory ifNotNil: [mandatory remove: aClass ifAbsent: [^nil]]! ! !SMCategory methodsFor: 'private' stamp: 'gh 6/28/2002 12:46'! addCategory: cat "Add a category as a subcategory to self. The collection of subcategories is lazily instantiated." subCategories ifNil: [subCategories _ OrderedCollection new]. cat parent ifNotNil: [cat parent removeCategory: cat ]. subCategories add: cat. cat parent: self. ^cat! ! !SMCategory methodsFor: 'private' stamp: 'gk 9/23/2003 21:59'! addObject: anObject "Add to this category. This should only be called from SMCategorizableObject>>addCategory: to ensure consistency." (objects includes: anObject) ifFalse:[objects add: anObject]! ! !SMCategory methodsFor: 'private' stamp: 'gk 8/8/2003 10:03'! delete "Delete me. Disconnect me from my objects and my parent. Then delete my subcategories." super delete. self removeFromObjects; removeFromParent. self subCategories do: [:c | c delete ] ! ! !SMCategory methodsFor: 'private' stamp: 'gh 6/28/2002 12:41'! parent: aCategory "Change the parent category. This method relies on that somebody else updates the parent's subCategories collection." parent _ aCategory! ! !SMCategory methodsFor: 'private' stamp: 'gk 11/14/2003 11:53'! removeDeepFromObjects "Remove myself from my objects and then ask my subCategories to do the same." objects copy do: [:obj | obj removeCategory: self]. subCategories do: [:cat | cat removeDeepFromObjects]! ! !SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:03'! removeFromObjects "Remove myself from my objects." objects copy do: [:obj | obj removeCategory: self]! ! !SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:28'! removeFromParent "Remove me from my parent." parent ifNotNil: [parent removeCategory: self]! ! !SMCategory methodsFor: 'private' stamp: 'gh 12/1/2002 20:28'! removeObject: anObject "Remove from this category. This should only be called from SMCategorizableObject>>removeCategory: to ensure consistency." ^objects remove: anObject! ! !SMCategory methodsFor: 'accessing' stamp: 'gk 11/17/2003 13:51'! mandatory ^mandatory! ! !SMCategory methodsFor: 'accessing' stamp: 'gk 11/17/2003 14:01'! mandatory: aSet mandatory _ aSet! ! !SMCategory methodsFor: 'accessing' stamp: 'gk 11/17/2003 21:35'! mandatoryFor: aClass "Is this category mandatory for instances of ?" ^mandatory ifNil: [false] ifNotNil: [mandatory includes: aClass]! ! !SMCategory methodsFor: 'accessing' stamp: 'gh 8/1/2002 16:54'! objects "Return all objects in this category." ^objects! ! !SMCategory methodsFor: 'accessing' stamp: 'gk 8/7/2003 23:42'! packages "Return all packages in this category." ^objects select: [:p | p isPackage]! ! !SMCategory methodsFor: 'accessing' stamp: 'gh 6/27/2002 16:01'! parent ^parent! ! !SMCategory methodsFor: 'accessing' stamp: 'gh 6/27/2002 12:25'! subCategories subCategories ifNil: [^#()]. ^subCategories! ! !SMCategory methodsFor: 'testing' stamp: 'gh 12/1/2002 20:24'! hasSubCategories ^subCategories isEmptyOrNil not! ! !SMCategory methodsFor: 'testing' stamp: 'gk 8/7/2003 22:31'! includes: anObject "Answer if is in this category." ^objects includes: anObject! ! !SMCategory methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'! isCategory ^true! ! !SMCategory methodsFor: 'testing' stamp: 'gh 6/27/2002 13:31'! isTopCategory ^parent isNil! ! !SMCategory methodsFor: 'initialize-release' stamp: 'gk 11/17/2003 13:23'! initialize super initialize. name _ summary _ url _ ''. objects _ OrderedCollection new! ! !SMCategory methodsFor: 'printing' stamp: 'gk 1/29/2004 00:14'! path "Return my name with a full path of my parent names separated with slashes like: 'Squeak versions/Squeak3.5' " ^String streamContents: [:s | self parentsDo: [:cat | s nextPutAll: cat name; nextPutAll: '/']. s nextPutAll: self name]! ! !SMCategory methodsFor: 'printing' stamp: 'gh 8/16/2002 06:04'! printOn: aStream aStream nextPutAll: self class name, ': ', name! ! !SMCategory methodsFor: 'printing' stamp: 'gk 11/14/2003 00:13'! type ^'Category'! ! !SMCategory methodsFor: 'deprecated' stamp: 'gk 11/17/2003 13:52'! addMandatoryClass: aClass "Add as one of the SMObject types that I am mandatory for." mandatory ifNil: [mandatory _ Set new]. mandatory add: aClass! ! !SMCategory methodsFor: 'deprecated' stamp: 'gk 11/17/2003 13:51'! created: c updated: u name: n summary: s url: uu mandatory: m parentId: anId "Method used when recreating from storeOn: format. Note: That #addCategory: will set the parent variable." created _ c. updated _ u. name _ n. summary _ s. url _ uu. m ifTrue: [self addMandatoryClass: SMPackage]. anId ifNotNil: [(map categoryWithId: anId) addCategory: self]! ! !SMCategory methodsFor: 'deprecated' stamp: 'gh 12/2/2002 20:00'! parentId: anId "Method used when recreating from storeOn: format. Note: That #addCategory: will set the parent variable." (map categoryWithId: anId) addCategory: self! ! !SMCategory methodsFor: 'view' stamp: 'gk 11/17/2003 14:50'! getLink: aView "Return a link for using on the web." ^aView linklocal: '/category/', id asString text: name! ! !SMCategory methodsFor: 'view' stamp: 'gh 8/1/2002 16:38'! viewFor: uiObject "This is a double dispatch mechanism for multiple views for multiple uis." ^uiObject categoryViewOn: self! ! !SMCategory commentStamp: 'gk 3/8/2004 19:44' prior: 0! An SMCategory is a "tag" that can be attached to SMCategorizableObjects in order to classify them. The SMCategories are arranged in a strict hierarchy and each SMCategory both knows it's parent and it's subcategories. The instvar objects holds all SMObjects belonging to this category. Instvars name and summary are already inherited from SMObject and describe the category. The instvar url can be used to refer to a web page that can explain the category in more detail, typically a page at the Squeak Swiki. SMCategory adds an instance variable called mandatory holding a Set with the classes (SMPackage, SMPackageRelease, SMAccount, SMResource etc) that must belong to at least one subcategory of this SMCategory. Obviously not many categories will be mandatory for each class. The category tree is maintained by a few trusted people so that chaos will not reign. :-) ! !SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:13'! = anObject ^self withoutListWrapper = anObject withoutListWrapper! ! !SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:19'! asString ^item name! ! !SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:35'! category ^item! ! !SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'gk 3/4/2004 10:18'! contents "This is the message that returns the contents of this wrapper. We return a collection of wrappers around all the children of our model." ^item subCategories collect: [:e | SMCategoryWrapper with: e]! ! !SMCategoryWrapper methodsFor: 'as yet unclassified' stamp: 'ar 2/9/2004 02:13'! hash ^self withoutListWrapper hash! ! !SMDVSInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:54'! install "Install using DVS." | imagePackageLoader streamPackageLoader packageInfo packageManager baseName current new manager | self cache; unpack. imagePackageLoader _ Smalltalk at: #ImagePackageLoader ifAbsent: []. streamPackageLoader _ Smalltalk at: #StreamPackageLoader ifAbsent: []. packageInfo _ Smalltalk at: #PackageInfo ifAbsent: []. packageManager _ Smalltalk at: #FilePackageManager ifAbsent: []. ({ imagePackageLoader. streamPackageLoader. packageInfo. packageManager } includes: nil) ifTrue: [ (self confirm: ('DVS support is not loaded, but would be helpful in loading ', unpackedFileName, '. It isn''t necessary, but if you intend to use DVS later it would be a good idea to load it now. Load it from SqueakMap?')) ifTrue: [ self class loadDVS. ^self install ] ifFalse: [ ^self fileIn ]]. baseName _ packageRelease name. dir rename: unpackedFileName toBe: (baseName, '.st'). unpackedFileName _ baseName, '.st'. (manager _ packageManager allManagers detect: [ :pm | pm packageName = baseName ] ifNone: []) ifNotNil: [ current _ imagePackageLoader new package: (packageInfo named: baseName). new _ streamPackageLoader new stream: (dir readOnlyFileNamed: unpackedFileName). (new changesFromBase: current) fileIn ] ifNil: [ self fileIn. manager _ packageManager named: baseName. ]. manager directory: dir. packageManager changed: #allManagers. packageRelease noteInstalled! ! !SMDVSInstaller commentStamp: '' prior: 0! This is an installer class for DVS packages. It handles packages categorized with package format as DVS and with a download filename with extensions .st or .st.gz. This class can function without DVS installed, needed classes are looked up dynamically.! !SMDVSInstaller class methodsFor: 'testing' stamp: 'gk 10/1/2003 13:51'! canInstall: aPackage "Can I install this? First we check if class StreamPackageLoader is available, otherwise DVS isn't installed. Then we check if the package is categorized with package format DVS - currently we have hardcoded the id of that category." | fileName | Smalltalk at: #StreamPackageLoader ifPresentAndInMemory: [ :loader | fileName _ aPackage downloadFileName. fileName ifNil: [^false]. fileName _ fileName asLowercase. ^((fileName endsWith: '.st') or: [fileName endsWith: '.st.gz']) and: [aPackage categories includes: "The DVS format category" (SMSqueakMap default categoryWithId: 'b02f51f4-25b4-4117-9b65-f346215a8e41')]]. ^false! ! !SMDVSInstaller class methodsFor: 'loading' stamp: 'gk 10/1/2003 13:51'! loadDVS "Load the DVS package from SqueakMap." SMSqueakMap default installPackageWithId: '100d59d0-bf81-4e74-a4fe-5a2fd0c6b4ec'! ! !SMDefaultInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 20:52'! install "This service should bring the package to the client, unpack it if necessary and install it into the image. The package is notified of the installation." self cache; unpack; fileIn. packageRelease noteInstalled ! ! !SMDefaultInstaller methodsFor: 'private' stamp: 'yo 8/17/2004 10:04'! fileIn "Installing in the standard installer is simply filing in. Both .st and .cs files will file into a ChangeSet of their own. We let the user confirm filing into an existing ChangeSet or specify another ChangeSet name if the name derived from the filename already exists." | fileStream | ((unpackedFileName endsWith: (FileDirectory dot, FileStream st)) or: [unpackedFileName endsWith: (FileDirectory dot, FileStream cs)]) ifTrue:[ fileStream _ dir readOnlyFileNamed: unpackedFileName. fileStream setConverterForCode. self fileIntoChangeSetNamed: (fileStream localName sansPeriodSuffix) fromStream: fileStream. ^ self]. " ((unpackedFileName endsWith: (FileDirectory dot, FileStream multiSt)) or: [unpackedFileName endsWith: (FileDirectory dot, FileStream multiCs)]) ifTrue:[ fileStream _ dir readOnlyFileNamed: unpackedFileName. fileStream converter: UTF8TextConverter new. self fileIntoChangeSetNamed: (fileStream localName sansPeriodSuffix) fromStream: fileStream. ^ self]. " self error: 'Filename should end with a proper extension'. ! ! !SMDefaultInstaller commentStamp: '' prior: 0! An installer takes care of installing SqueakMap packages represented by SMCards. This installer handles packages that consist of classical fileins (single changesets and .st-files) and optional gzip-decompression of those. Deciding if a package is installable and instantiating the correct installer class is done on the class side in SMInstaller, to see how this installer gets chosen - see SMDefaultInstaller class>>canInstall:. ! !SMDefaultInstaller class methodsFor: 'testing' stamp: 'yo 7/5/2004 20:21'! canInstall: aPackage "Answer if this class can install/upgrade the package. This installer handles .st, .cs, .st.gz and .cs.gz files." | fileName | fileName _ aPackage downloadFileName. fileName ifNil: [^false]. fileName _ fileName asLowercase. ^ FileStream sourceFileSuffixes anySatisfy: [:each | (fileName endsWith: (FileDirectory dot, each)) or: [ fileName endsWith: (FileDirectory dot, each, '.gz')]. ]. ! ! !SMDocument methodsFor: 'cache' stamp: 'gk 3/8/2004 19:51'! ensureInCache "Makes sure the file is in the cache." self subclassResponsibility ! ! !SMDocument methodsFor: 'cache' stamp: 'gk 8/12/2003 17:09'! isCached "Is the file corresponding to me in the local file cache?" self subclassResponsibility ! ! !SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:51'! author ^author! ! !SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:52'! author: aString author _ aString! ! !SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:52'! description ^description! ! !SMDocument methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:52'! description: aString description _ aString! ! !SMDocument methodsFor: 'initialize-release' stamp: 'gk 3/8/2004 19:53'! initialize description := author := ''! ! !SMDocument commentStamp: 'gk 3/8/2004 19:56' prior: 0! An SMDocument refers typically to a piece of digital information accessible through a URL. :-) This means it can be downloaded and cached. The instvar description describes the document and instvar author references the name and/or email of the original author. SMDocument has two subclasses - SMPackage and SMResource. Since SqueakMap is primarily meant for keeping track of installable source packages of Squeak software, a specific subclass handles those. The main difference is that an SMPackage has SMPackageReleases - versions of the package. An SMResource has no versions and is always referred to as it is *now*, but it does have a field for keeping track of the current version name.! !SMEmbeddedResource methodsFor: 'testing' stamp: 'gk 8/12/2003 17:10'! isCached "Is the file corresponding to me in the local file cache? Well consider it as true since I am embedded in the map." ^true! ! !SMEmbeddedResource methodsFor: 'services' stamp: 'gk 3/8/2004 19:58'! download "A dummy method to respond as other resources would." ^true! ! !SMEmbeddedResource methodsFor: 'services' stamp: 'gk 8/13/2003 15:54'! ensureInCache "Makes sure the file is in the cache." ^true! ! !SMEmbeddedResource methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:58'! content ^content! ! !SMEmbeddedResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 02:05'! content: aString content _ aString! ! !SMEmbeddedResource methodsFor: 'accessing' stamp: 'gk 3/8/2004 19:58'! contents "Answers the content string." ^content! ! !SMEmbeddedResource commentStamp: 'gk 3/8/2004 20:01' prior: 0! An embedded resource is simply a String resource, held in instvar #content, that is stored inside the map. No download is needed. This means that embedded resources should be "small" and typically only be used for resources that are needed to be available at all times without downloading. A typical example is meta data for other SMObjects. ! !SMExternalResource methodsFor: 'services' stamp: 'gk 8/13/2003 15:42'! download "Force a download into the cache regardless if it is already there." ^map cache download: self! ! !SMExternalResource methodsFor: 'services' stamp: 'gk 8/13/2003 15:54'! ensureInCache "Makes sure the file is in the cache." ^map cache add: self! ! !SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:13'! cacheDirectory ^ map cache directoryForResource: self! ! !SMExternalResource methodsFor: 'accessing' stamp: 'gk 3/8/2004 20:08'! contents "Return the contents of a stream from the downloaded resource. Not yet tested, this resource returns the stream and not its contents." map cache add: self. ^self cacheDirectory readOnlyFileNamed: self downloadFileName! ! !SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:13'! downloadFileName "Cut out the filename from the url." downloadUrl isEmpty ifTrue: [^nil]. ^downloadUrl asUrl path last! ! !SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:14'! downloadUrl ^ downloadUrl! ! !SMExternalResource methodsFor: 'accessing' stamp: 'btr 5/28/2003 04:15'! downloadUrl: anUrl downloadUrl _ anUrl! ! !SMExternalResource methodsFor: 'testing' stamp: 'gk 8/13/2003 15:32'! isCached "Is the file corresponding to me in the local file cache?" ^map cache includes: self! ! !SMExternalResource commentStamp: 'gk 3/8/2004 20:09' prior: 0! An external resource is a downloadable resource. The instance variable downloadUrl holds the URL to the resource and the resource is cacheable in the FileCache for the SqueakMap. An external resource can be used for any kind of document that is to be attached to another SMObject.! !SMFileCache methodsFor: 'accessing' stamp: 'gk 1/23/2004 10:26'! directory ^map packageCacheDirectory! ! !SMFileCache methodsFor: 'accessing' stamp: 'gk 3/1/2004 10:38'! directoryForPackage: aPackage "Returns the local path for storing the package cache's package file area. This also ensures that the path exists." | slash path dir | slash _ FileDirectory slash. path _ 'packages' , slash , aPackage id asString36 , slash. dir _ FileDirectory default on: self directory fullName, slash, path. dir assureExistence. ^dir! ! !SMFileCache methodsFor: 'accessing' stamp: 'gk 1/27/2004 14:34'! directoryForPackageRelease: aPackageRelease "Returns the local path for storing the package cache's version of a package file. This also ensures that the path exists." | slash path dir | slash _ FileDirectory slash. path _ 'packages' , slash , aPackageRelease package id asString36 , slash , aPackageRelease automaticVersionString. dir _ FileDirectory default on: self directory fullName, slash, path. dir assureExistence. ^dir! ! !SMFileCache methodsFor: 'accessing' stamp: 'gk 1/27/2004 14:34'! directoryForResource: aResource "Returns the local path for storing the package cache's version of a resource file. This also ensures that the path exists." | slash path dir | slash _ FileDirectory slash. path _ 'resources' , slash , aResource id asString36. dir _ FileDirectory default on: self directory fullName, slash, path. dir assureExistence. ^dir! ! !SMFileCache methodsFor: 'accessing' stamp: 'btr 5/27/2003 16:24'! map ^ map! ! !SMFileCache methodsFor: 'services' stamp: 'gk 7/10/2004 03:53'! add: aPackage "Conditionally download the package into the cache. Return true on success, otherwise false." ^(self includes: aPackage) ifTrue: [true] ifFalse: [self download: aPackage]! ! !SMFileCache methodsFor: 'services' stamp: 'gk 5/23/2004 20:46'! download: aDownloadable "Download the file for this SM object into the local file cache. If the file already exists, delete it. No unpacking or installation into the running image." | stream file fileName dir | [fileName _ aDownloadable downloadFileName. fileName ifNil: [self inform: 'No download url, can not download.'. ^ false]. fileName isEmpty ifTrue: [self inform: 'Download url lacks filename, can not download.'. ^ false]. dir _ aDownloadable cacheDirectory. [(dir fileExists: fileName) ifTrue: [dir deleteFileNamed: fileName]. stream _ aDownloadable downloadUrl asUrl retrieveContents contentStream binary. file _ dir newFileNamed: fileName. file nextPutAll: stream contents] ensure: [file ifNotNil: [file close]]] on: Error do: [^ false]. ^ true! ! !SMFileCache methodsFor: 'services' stamp: 'gk 8/13/2003 15:37'! includes: anSMObject ^(anSMObject cacheDirectory) fileExists: anSMObject downloadFileName! ! !SMFileCache methodsFor: 'initialize' stamp: 'gk 1/23/2004 10:29'! forMap: aMap "Initialize the ache, make sure the cache dir exists." map _ aMap! ! !SMFileCache commentStamp: 'gk 3/8/2004 20:10' prior: 0! A repository for SMSqueakMap downloads. This behaves like a Set, responding to add: and include:, but also package contents may be forcibly refreshed with download:. The SqueakMap determines what path the cache resides at. Within the cache, there is a 'packages' directory containing UUID-based directories for each package containing further directories for each release. A 'resources' directory stores UUID-based directories for each Resource, with the file stored within that by its original name. Because the cache follows a Set protocol, it can be automatically traversed within Smalltalk's collection protocol, avoiding manual hassles.! !SMFileCache class methodsFor: 'instance creation' stamp: 'gk 1/23/2004 10:21'! newFor: aMap "This is the default creation method, responsible for ensuring the paths and such exist, and filling in defaults." ^self new forMap: aMap ! ! !SMInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:56'! download "This service should bring the package release to the client and also unpack it on disk if needed.  It will not install it into the running image though. Raises errors if operation does not succeed." self subclassResponsibility ! ! !SMInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:57'! install "This service should bring the package release to the client, unpack it if necessary and install it into the image. The package release should be notified of the installation using 'packageRelease noteInstalled'." self subclassResponsibility ! ! !SMInstaller methodsFor: 'services' stamp: 'gk 7/14/2004 15:38'! upgrade "This service performs an upgrade to the selected release. Currently it just defaults to the same operation as an install - which is handled fine by Monticello, but not necessarily for other formats." ^self install! ! !SMInstaller methodsFor: 'accessing' stamp: 'gk 11/16/2003 22:03'! packageRelease: aPackageRelease packageRelease _ aPackageRelease! ! !SMInstaller methodsFor: 'private' stamp: 'gk 7/13/2004 02:43'! silent "Can we ask questions?" ^packageRelease ifNotNil: [packageRelease map silent] ifNil: [false]! ! !SMInstaller commentStamp: '' prior: 0! An installer takes care of installing SqueakMap packages represented by SMCards. Deciding if a package is installable and instantiating the correct installer class is done on the class side, see implementors of #canInstall:. Two methods need to be implemented by subclasses - download and install. Upgrade can also be specialized by implementing #upgrade, otherwise it will default to #install.! !SMInstaller class methodsFor: 'instance creation' stamp: 'gk 11/16/2003 23:33'! classForPackageRelease: aPackageRelease "Decide which subclass to instantiate. We detect and return the first subclass that wants to handle the release going recursively leaf first so that subclasses gets first chance if several classes compete over the same packages, like for example SMDVSInstaller that also uses the .st file extension." self subclasses do: [:ea | (ea classForPackageRelease: aPackageRelease) ifNotNilDo: [:class | ^ class]]. ^(self canInstall: aPackageRelease) ifTrue: [self]! ! !SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:49'! canInstall: aPackageRelease "Nope, I am an abstract class and can not install anything. But my subclasses should reimplement this." ^ false! ! !SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:50'! isInstallable: aPackageRelease "Detect if any subclass can handle the package release." aPackageRelease ifNil: [^false]. ^(self classForPackageRelease: aPackageRelease) notNil! ! !SMInstaller class methodsFor: 'testing' stamp: 'gk 11/16/2003 23:49'! isUpgradeable: aPackageRelease "Detect if any subclass can handle the release. Currently we assume that upgrade is the same as install." ^self isInstallable: aPackageRelease! ! !SMInstaller class methodsFor: 'changeset utilities' stamp: 'nk 11/30/2002 17:18'! basicNewChangeSet: newName "This method copied here to ensure SqueakMap is independent of ChangeSorter. " Smalltalk at: #ChangeSorter ifPresentAndInMemory: [:cs | ^ cs basicNewChangeSet: newName]. (self changeSetNamed: newName) ifNotNil: [self error: 'The name ' , newName , ' is already used']. ^ ChangeSet basicNewNamed: newName! ! !SMInstaller class methodsFor: 'changeset utilities' stamp: 'gh 10/31/2002 10:11'! changeSetNamed: newName "This method copied here to ensure SqueakMap is independent of ChangeSorter." Smalltalk at: #ChangeSorter ifPresentAndInMemory: [ :cs | ^cs changeSetNamed: newName ]. ^ChangeSet allInstances detect: [ :cs | cs name = newName ] ifNone: [ nil ].! ! !SMInstaller class methodsFor: 'deprecated' stamp: 'md 7/16/2004 16:42'! forPackage: aPackage directory: aDirectory "Deprecated. Kept for backwards compatibility. Installing a package means installing the latest available release." self deprecated: 'Method Deprecated: Use SMInstaller>>forPackageRelease: instead. A directory is not needed in SM2, it has its own cache.'. ^self forPackageRelease: aPackage lastRelease! ! !SMInstaller class methodsFor: 'deprecated' stamp: 'gk 11/17/2003 00:02'! forPackageRelease: aPackageRelease "Instantiate the first class suitable to install the package release. If no installer class is found we raise an Error." | class | aPackageRelease ifNil: [self error: 'No package release specified to find installer for.']. class _ self classForPackageRelease: aPackageRelease. ^class ifNil: [self error: 'No installer found for package ', aPackageRelease name, '.'] ifNotNil: [class new packageRelease: aPackageRelease]! ! !SMLanguageInstaller methodsFor: 'services' stamp: 'mir 7/21/2004 19:28'! install "This service should bring the package to the client, unpack it if necessary and install it into the image. The package is notified of the installation." self cache; unpack. [NaturalLanguageTranslator mergeTranslationFileNamed: unpackedFileName] ensure: [packageRelease noteInstalled]! ! !SMLanguageInstaller class methodsFor: 'testing' stamp: 'mir 7/21/2004 19:28'! canInstall: aPackage "Answer if this class can install the package. We handle .translation files optionally compressed." | fileName | fileName _ aPackage downloadFileName. fileName ifNil: [^false]. fileName _ fileName asLowercase. ^(fileName endsWith: '.translation') or: [ (fileName endsWith: '.tra') or: [ (fileName endsWith: '.tra.gz') or: [ fileName endsWith: '.translation.gz']]]! ! !SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 11:29'! filterAutoInstall ^[:package | package isInstallable]! ! !SMLoader methodsFor: 'filters' stamp: 'gk 7/13/2004 15:28'! filterAvailable ^[:package | package isAvailable]! ! !SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:08'! filterInstalled ^[:package | package isInstalled]! ! !SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:08'! filterNotInstalledYet ^[:package | package isInstalled not]! ! !SMLoader methodsFor: 'filters' stamp: 'dvf 10/25/2002 17:07'! filterNotUptoDate ^[:package | package isAvailable]! ! !SMLoader methodsFor: 'filters' stamp: 'gk 1/28/2004 23:42'! filterPublished ^[:package | package isPublished]! ! !SMLoader methodsFor: 'filters' stamp: 'gk 7/13/2004 15:28'! filterSafelyAvailable ^[:package | package isSafelyAvailable]! ! !SMLoader methodsFor: 'filters' stamp: 'nk 7/30/2004 17:55'! filterVersion "Ignore spaces in the version string, they're sometimes spurious. Not used anymore." ^ [:package | package categories anySatisfy: [:cat | cat name , '*' match: (SystemVersion current version copyWithout: $ )]]! ! !SMLoader methodsFor: 'accessing' stamp: 'gk 7/10/2004 15:45'! changeFilters: anObject "Update my selection." | oldItem index | oldItem := self selectedPackageOrRelease. filters := anObject. self packagesListIndex: ((index := self packageList indexOf: oldItem) ifNil: [0] ifNotNil: [index]). self noteChanged! ! !SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 16:34'! packagesListIndex ^self packageWrapperList indexOf: self selectedItemWrapper! ! !SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 16:53'! packagesListIndex: anObject self selectedItemWrapper: (anObject = 0 ifTrue:[nil] ifFalse: [(self packageWrapperList at: anObject)]) ! ! !SMLoader methodsFor: 'accessing' stamp: 'gk 7/10/2004 03:58'! selectedCategory "Return selected category." ^(self selectedCategoryWrapper isNil) ifFalse: [self selectedCategoryWrapper withoutListWrapper]! ! !SMLoader methodsFor: 'accessing' stamp: 'ar 2/9/2004 02:14'! selectedCategoryWrapper ^selectedCategoryWrapper! ! !SMLoader methodsFor: 'accessing' stamp: 'ar 2/9/2004 02:53'! selectedCategoryWrapper: aWrapper selectedCategoryWrapper := aWrapper. self selectedItemWrapper: nil. self changed: #selectedCategoryWrapper. self changed: #packageWrapperList.! ! !SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 15:04'! selectedItemWrapper ^selectedItemWrapper! ! !SMLoader methodsFor: 'accessing' stamp: 'dvf 9/21/2003 15:05'! selectedItemWrapper: aWrapper selectedItemWrapper _ aWrapper. self changed: #selectedItemWrapper. self contentsChanged! ! !SMLoader methodsFor: 'gui building' stamp: 'dvf 9/20/2002 21:33'! addPackagesTo: window at: fractions plus: verticalOffset "Add the list for packages, and answer the verticalOffset plus the height added" | divider listMorph | listMorph _ self buildMorphicPackagesList. listMorph borderWidth: 0. divider _ BorderedSubpaneDividerMorph forBottomEdge. Preferences alternativeWindowLook ifTrue:[ divider extent: 4@4; color: Color transparent; borderColor: #raised; borderWidth: 2. ]. window addMorph: listMorph ! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 5/27/2004 00:17'! browseCacheDirectory "Open a FileList2 on the directory for the package or release." | item dir win | item := self selectedPackageOrRelease. item ifNil: [^nil]. dir := item isPackage ifTrue: [squeakMap cache directoryForPackage: item] ifFalse: [squeakMap cache directoryForPackageRelease: item]. win _ FileList2 morphicViewOnDirectory: dir. " withLabel: item name, ' cache directory'." win openInWorld ! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 7/11/2004 03:04'! buildMorphicCategoriesList "Create the hierarchical list holding the category tree." | list | list := (SimpleHierarchicalListMorph on: self list: #categoryWrapperList selected: #selectedCategoryWrapper changeSelected: #selectedCategoryWrapper: menu: #categoriesMenu: keystroke: nil) autoDeselect: false; enableDrag: false; enableDrop: true; yourself. list setBalloonText: 'The categories are structured in a tree. Packages and package releases belong to several categories. You can add one or more categories as filters and enable them in the menu.'. " list scroller submorphs do:[:each| list expandAll: each]." list adjustSubmorphPositions. ^list! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 7/11/2004 03:04'! buildMorphicPackagesList "Create the hierarchical list holding the packages and releases." ^(SimpleHierarchicalListMorph on: self list: #packageWrapperList selected: #selectedItemWrapper changeSelected: #selectedItemWrapper: menu: #packagesMenu: keystroke: nil) autoDeselect: false; enableDrag: false; enableDrop: true; setBalloonText: 'Here all packages with their releases are listed that should be displayed according the current filter.'; yourself! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 7/11/2004 03:03'! buildPackagePane "Create the text area to the right in the loader." | ptm | ptm _ PluggableTextMorph on: self text: #contents accept: nil readSelection: nil "#packageSelection " menu: nil. ptm setBalloonText: 'This is where the selected package or package release is displayed.'. ptm lock. ^ptm! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 5/25/2004 12:21'! buildSearchPane | typeInView | typeInView _ PluggableTextMorph on: self text: nil accept: #findPackage:notifying: readSelection: nil menu: nil. typeInView setBalloonText:'To find a package type in a fragment of its name and hit return'. typeInView acceptOnCR: true. (typeInView respondsTo: #hideScrollBarsIndefinitely) ifTrue: [ typeInView hideScrollBarsIndefinitely] ifFalse: [typeInView hideScrollBarIndefinitely]. ^typeInView! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 7/13/2004 16:14'! createWindow "Create the package loader window." self addMorph: (self buildSearchPane borderWidth: 0) frame: (0.0 @ 0.0 corner: 0.3 @ 0.07). self addMorph: (self buildMorphicPackagesList borderWidth: 0) frame: (0.0 @ 0.07 corner: 0.3 @ 0.6). self addMorph: (self buildMorphicCategoriesList borderWidth: 0) frame: (0.0 @ 0.6 corner: 0.3 @ 1.0). self addMorph: (self buildPackagePane borderWidth: 0) frame: (0.3 @ 0.0 corner: 1.0 @ 1.0). self on: #mouseEnter send: #paneTransition: to: self. self on: #mouseLeave send: #paneTransition: to: self! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 7/12/2004 11:14'! defaultButtonPaneHeight "Answer the user's preferred default height for new button panes." ^ Preferences parameterAt: #defaultButtonPaneHeight ifAbsentPut: [25]! ! !SMLoader methodsFor: 'gui building' stamp: 'gk 11/18/2003 13:45'! help "Present help text. If there is a web server available, offer to open it. Use the WebBrowser registry if possible, or Scamper if available." | message browserClass | message _ 'Welcome to the SqueakMap package loader. The names of packages are followed by (installed version -> latest version). If there is no arrow, your installed version of the package is the latest. The checkbox menu items at the bottom let you modify which packages you''ll see. Take a look at them - only some packages are shown initially. The options available for a package depend on how it was packaged. If you like a package or have comments on it, please contact the author or the squeak mailing list.'. browserClass _ Smalltalk at: #WebBrowser ifPresent: [ :registry | registry default ]. browserClass _ browserClass ifNil: [ Smalltalk at: #Scamper ifAbsent: [ ^self inform: message ]]. (self confirm: message, ' Would you like to view more detailed help on the SqueakMap swiki page?') ifTrue: [ browserClass openOnUrl: 'http://minnow.cc.gatech.edu/squeak/2726' asUrl]! ! !SMLoader methodsFor: 'gui building' stamp: 'dvf 9/20/2002 23:18'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (self respondsTo: selector) ifTrue: [^ self perform: selector] ifFalse: [^ super perform: selector orSendTo: otherTarget]! ! !SMLoader methodsFor: 'lists' stamp: 'gk 7/12/2004 01:16'! categoryWrapperList "Create the wrapper list for the hierarchical list. We sort the categories by name but ensure that 'Squeak versions' is first if it exists." | list first | list := (((squeakMap categories select:[:each | each parent == nil]) asArray sort:[:c1 :c2 | c1 name <= c2 name])). first := list detect:[:any | any name = 'Squeak versions'] ifNone:[nil]. first ifNotNil:[ list := list copyWithout: first. list := {first}, list]. ^list collect:[:cat | SMCategoryWrapper with: cat model: self].! ! !SMLoader methodsFor: 'lists' stamp: 'gk 7/13/2004 17:10'! packageList "Return a list of the SMPackages that should be visible by applying all the filters. Also filter based on the currently selected category - if any." | list selectedCategory | list := packagesList ifNil: [ packagesList := self packages select: [:p | filters allSatisfy: [:currFilter | currFilter isSymbol ifTrue: [(self perform: currFilter) value: p] ifFalse: [ self package: p filteredByCategory: (squeakMap object: currFilter)]]]]. selectedCategoryWrapper ifNil:[self updateLabel: list. ^list]. selectedCategory := selectedCategoryWrapper category. list := list select: [:each | self package: each filteredByCategory: selectedCategory]. self updateLabel: list. ^list! ! !SMLoader methodsFor: 'lists' stamp: 'dvf 9/21/2003 16:36'! packageNameList ^self packageWrapperList collect: [:e | e withoutListWrapper name]! ! !SMLoader methodsFor: 'lists' stamp: 'gk 7/9/2004 01:36'! packageWrapperList "Return the list with each element wrapped so that it can be used in a SimpleHierarchicalListMorph." ^self packageList collect: [:e | SMPackageWrapper with: e]! ! !SMLoader methodsFor: 'lists' stamp: 'dvf 9/21/2003 17:47'! raiseMenu: aMenu ^self packagesMenu: aMenu! ! !SMLoader methodsFor: 'lists' stamp: 'gk 7/13/2004 17:10'! updateLabel: packagesShown "Update the label of the window." self setLabel: 'SqueakMap Package Loader (', packagesShown size printString, '/', squeakMap packages size printString, ')'! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'! filterAdd: anObject self changeFilters: (self filters copyWith: anObject) ! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'! filterRemove: anObject self changeFilters: (self filters copyWithout: anObject) ! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/13/2004 15:49'! filterSpecs "Return a specification for the filter menu. Is called each time." | specs | specs := #( #('display only auto-installable packages' #filterAutoInstall 'display only packages that can be installed automatically') #('display only new available packages' #filterAvailable 'display only packages that are not installed or that have newer releases available.') #('display only new safely available packages' #filterSafelyAvailable 'display only packages that are not installed or that have newer releases available that are safe to install, meaning that they are published and meant for the current version of Squeak.') #('display only installed packages' #filterInstalled 'display only packages that are installed.') #('display only published packages' #filterPublished 'display only packages that have at least one published release.')) asOrderedCollection. categoriesToFilterIds do: [:catId | specs add: {'display only packages in ', (squeakMap object: catId) name. catId. 'display only packages that are in the category.'}]. ^ specs! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:47'! filters ^filters! ! !SMLoader methodsFor: 'filter utilities' stamp: 'dvf 10/25/2002 11:27'! labelForFilter: aFilterSymbol ^(self filterSpecs detect: [:fs | fs second = aFilterSymbol]) first! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/11/2004 22:29'! package: aPackage filteredByCategory: aCategory "Answer true if the package should be shown if we filter on . It should be shown if itself or any of its releases has the category." | releases | releases := aPackage releases. ^(aPackage hasCategoryOrSubCategoryOf: aCategory) or: [ releases anySatisfy: [:rel | rel hasCategoryOrSubCategoryOf: aCategory]]! ! !SMLoader methodsFor: 'filter utilities' stamp: 'dvf 10/25/2002 14:48'! showFilterString: aFilterSymbol ^(self stateForFilter: aFilterSymbol), (self labelForFilter: aFilterSymbol)! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:45'! stateForFilter: aFilterSymbol ^(self filters includes: aFilterSymbol) ifTrue: [''] ifFalse: [''] ! ! !SMLoader methodsFor: 'filter utilities' stamp: 'gk 7/10/2004 15:46'! toggleFilterState: aFilterSymbol ^(self filters includes: (aFilterSymbol)) ifTrue: [self filterRemove: aFilterSymbol] ifFalse: [self filterAdd: aFilterSymbol]! ! !SMLoader methodsFor: 'menus' stamp: 'gk 7/13/2004 17:20'! addFiltersToMenu: aMenu | filterSymbol help | self filterSpecs do: [:filterArray | filterSymbol := filterArray second. help := filterArray third. aMenu addUpdating: #showFilterString: target: self selector: #toggleFilterState: argumentList: (Array with: filterSymbol). aMenu balloonTextForLastItem: help]. aMenu addLine; addList: #(('uncheck all filters' uncheckFilters 'unchecks all filters so that all packages are listed')) ! ! !SMLoader methodsFor: 'menus' stamp: 'gk 7/10/2004 03:58'! categoriesMenu: aMenu "Answer the categories-list menu." self selectedCategory ifNotNil: [aMenu addList: self categorySpecificOptions; addLine]. aMenu addList: self generalOptions. self addFiltersToMenu: aMenu. ^aMenu! ! !SMLoader methodsFor: 'menus' stamp: 'md 10/20/2004 15:33'! categorySpecificOptions | choices | choices := OrderedCollection new. (categoriesToFilterIds includes: self selectedCategory id) ifTrue: [ choices add: #('remove filter' #removeSelectedCategoryAsFilter 'Remove the filter for the selected category.')] ifFalse: [ choices add: #('add as filter' #addSelectedCategoryAsFilter 'Add the selected category as a filter so that only packages in that category are shown.')]. categoriesToFilterIds isEmpty ifFalse: [ choices add: #('remove all category filters' #removeCategoryFilters 'Remove all category filters.')]. ^ choices! ! !SMLoader methodsFor: 'menus' stamp: 'gk 7/14/2004 16:30'! generalOptions ^#(#('help' #help) #('update map from the net' loadUpdates) #('upgrade all installed packages' upgradeInstalledPackagesNoConfirm) #('upgrade all installed packages confirming each' upgradeInstalledPackagesConfirm) #('put list in paste buffer' listInPasteBuffer) #('save filters as default' saveFiltersAsDefault) #- ) ! ! !SMLoader methodsFor: 'menus' stamp: 'gk 7/9/2004 19:44'! packageSpecificOptions | choices packageOrRelease | packageOrRelease := self selectedPackageOrRelease. choices := OrderedCollection new. packageOrRelease isInstallable ifTrue: [ choices add: #('install' #installPackageRelease 'Install selected package or release, first downloading into the cache if needed.')]. (packageOrRelease isDownloadable and: [packageOrRelease isCached]) ifTrue: [ choices add: #('browse cache' #browseCacheDirectory 'Browse cache directory of selected package or package release.')]. (packageOrRelease isPackageRelease and: [packageOrRelease isDownloadable]) ifTrue: [ choices add: #('copy from cache' #cachePackageReleaseAndOfferToCopy 'Download selected release into cache first if needed, and then offer to copy it somewhere else.' ). choices add: #('force download into cache' #downloadPackageRelease 'Force a download of the selected release into the cache.' )]. choices add: #('email package maintainers' emailPackageMaintainers 'Open an editor to send an email to the owner and co-maintainers of this package.'). ^ choices! ! !SMLoader methodsFor: 'menus' stamp: 'gk 7/9/2004 03:04'! packagesMenu: aMenu "Answer the packages-list menu." self selectedPackageOrRelease ifNotNil: [aMenu addList: self packageSpecificOptions; addLine]. aMenu addList: self generalOptions. self addFiltersToMenu: aMenu. ^aMenu! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'! addSelectedCategoryAsFilter "Add a new filter that filters on the currently selected category. Make it enabled as default." categoriesToFilterIds add: self selectedCategory id! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 18:50'! cachePackageReleaseAndOfferToCopy "Cache package release, then offer to copy it somewhere. Answer the chosen file's location after copy, or the cache location if no directory was chosen." | release installer newDir newName newFile oldFile oldName | release _ self selectedPackageOrRelease. release isPackageRelease ifFalse: [ self error: 'Should be a package release!!']. installer _ SMInstaller forPackageRelease: release. [Cursor wait showWhile: [ installer cache]] on: Error do: [:ex | | msg | msg := ex messageText ifNil: [ex asString]. self informException: ex msg: ('Error occurred during download:\', msg, '\') withCRs. ^nil ]. oldName _ installer fullFileName. newDir _ FileList2 modalFolderSelector: installer directory. newDir ifNil: [ ^oldName ]. newDir = installer directory ifTrue: [ ^oldName ]. newName _ newDir fullNameFor: installer fileName. newFile _ FileStream newFileNamed: newName. newFile ifNil: [ ^oldName ]. oldFile _ FileStream readOnlyFileNamed: oldName. oldFile ifNil: [ ^nil ]. [[ newDir copyFile: oldFile toFile: newFile ] ensure: [ oldFile close. newFile close ]] on: Error do: [ :ex | ^oldName ]. ^newName! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 18:50'! downloadPackageRelease "Force a download of the selected package release into the cache." | release | release _ self selectedPackageOrRelease. release isPackageRelease ifFalse: [ self error: 'Should be a package release!!']. [Cursor wait showWhile: [ (SMInstaller forPackageRelease: release) download] ] on: Error do: [:ex | | msg | msg := ex messageText ifNil: [ex asString]. self informException: ex msg: ('Error occurred during download:\', msg, '\') withCRs]! ! !SMLoader methodsFor: 'actions' stamp: 'dew 7/13/2004 11:24'! emailPackageMaintainers "Send mail to package owner and co-maintainers." | item package toAddresses | item _ self selectedPackageOrRelease. package _ item isPackageRelease ifTrue: [item package] ifFalse: [item]. "(this logic should be moved to MailMessage as soon as it can handle multiple To: addresses)" toAddresses _ '<', package owner email, '>'. package maintainers ifNotNil: [ package maintainers do: [:maintainer | toAddresses _ toAddresses, ', <', maintainer email, '>']]. SMUtilities sendMailTo: toAddresses regardingPackageRelease: item! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 16:04'! findPackage: aString notifying: aView "Search and select a package with the given (sub) string" | index list match | match := aString asString asLowercase. index := self packagesListIndex. list := self packageNameList. list isEmpty ifTrue: [^self]. index + 1 to: list size do: [:i | ((list at: i) asLowercase includesSubString: match) ifTrue: [^self packagesListIndex: i]]. "wrap around" 1 to: index do: [:i | ((list at: i) asLowercase includesSubString: match) ifTrue: [^self packagesListIndex: i]]. self inform: 'No package matching ' , aString asString! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/15/2004 17:22'! installPackageRelease "Install selected package or release. The cache is used." | item release | item _ self selectedPackageOrRelease. item isPackageRelease ifTrue: [ (item isPublished or: [self confirm: 'Selected release is not published yet, install anyway?']) ifTrue: [^self installPackageRelease: item]] ifFalse: [ release _ item lastPublishedReleaseForCurrentSystemVersion. release ifNil: [ (self confirm: 'The package has no published release for your Squeak version, try releases for any Squeak version?') ifTrue: [ release _ item lastPublishedRelease. release ifNil: [ (self confirm: 'The package has no published release at all, take the latest of the unpublished releases?') ifTrue: [release _ item lastRelease]]]]. release ifNotNil: [^self installPackageRelease: release]]! ! !SMLoader methodsFor: 'actions' stamp: 'gk 11/18/2003 02:19'! listInPasteBuffer "Useful when talking with people etc. Uses the map to produce a nice String." Clipboard clipboardText: (String streamContents: [:s | packagesList do: [:p | s nextPutAll: p nameWithVersionLabel; cr ]]) asText! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/10/2004 18:51'! loadUpdates [Cursor wait showWhile: [ squeakMap loadUpdates. self noteChanged ] ] on: Error do: [:ex | self informException: ex msg: ('Error occurred when updating map:\', ex messageText, '\') withCRs]! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'! removeCategoryFilters "Remove all category filters." categoriesToFilterIds := OrderedCollection new! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'! removeSelectedCategoryAsFilter "Remove the filter that filters on the currently selected category." categoriesToFilterIds remove: self selectedCategory id! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/12/2004 14:42'! saveFiltersAsDefault "Save the current filters as default so that they are selected the next time the loader is opened." DefaultFilters := filters copy. DefaultCategoriesToFilterIds := categoriesToFilterIds copy! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/13/2004 16:05'! uncheckFilters "Uncheck all filters." filters := OrderedCollection new. self noteChanged! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/13/2004 15:25'! upgradeInstalledPackages "Tries to upgrade all installed packages to the latest published release for this version of Squeak. So this is a conservative approach." | installed old myRelease toUpgrade info | installed := squeakMap installedPackages. old := squeakMap oldPackages. old isEmpty ifTrue: [ ^self inform: 'All ', installed size printString, ' installed packages are up to date.']. toUpgrade := squeakMap upgradeableAndOldPackages. toUpgrade isEmpty ifTrue: [ ^self inform: 'None of the ', old size printString, ' old packages of the ', installed size printString, ' installed can be automatically upgraded. You need to upgrade them manually.']. old size < toUpgrade size ifTrue: [ info := 'Of the ', old size printString, ' old packages only ', toUpgrade size printString, ' can be upgraded. The following packages will not be upgraded: ', (String streamContents: [:s | (old removeAll: toUpgrade; yourself) do: [:p | s nextPutAll: p nameWithVersionLabel; cr]])] ifFalse: [info := 'All old packages upgradeable.']. (self confirm: info, ' About to upgrade the following packages: ', (String streamContents: [:s | toUpgrade do: [:p | s nextPutAll: p nameWithVersionLabel; cr]]), 'Proceed?') ifTrue: [ myRelease := self installedReleaseOfMe. [Cursor wait showWhile: [ squeakMap upgradeOldPackages. self inform: toUpgrade size printString, ' packages successfully upgraded.'. myRelease = self installedReleaseOfMe ifFalse: [self reOpen]. self noteChanged] ] on: Error do: [:ex | self informException: ex msg: ('Error occurred when upgrading old packages:\', ex messageText, '\') withCRs]]! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/14/2004 16:29'! upgradeInstalledPackagesConfirm "Tries to upgrade all installed packages to the latest published release for this version of Squeak. Confirms on each upgrade." ^ self upgradeInstalledPackagesConfirm: true! ! !SMLoader methodsFor: 'actions' stamp: 'gk 7/14/2004 16:29'! upgradeInstalledPackagesNoConfirm "Tries to upgrade all installed packages to the latest published release for this version of Squeak. No confirmation on each upgrade." ^ self upgradeInstalledPackagesConfirm: false! ! !SMLoader methodsFor: 'private' stamp: 'gk 11/16/2003 20:12'! contents | packageOrRelease | packageOrRelease _ self selectedPackageOrRelease. ^packageOrRelease ifNil: [''] ifNotNil: [packageOrRelease fullDescription] ! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/10/2004 04:04'! informException: ex msg: msg "Tell the user that an error has occurred. Offer to open debug notifier." (self confirm: msg, 'Would you like to open a debugger?') ifTrue: [ex pass]! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 04:07'! installPackageRelease: aRelease "Install a package release. The cache is used." | myRelease | aRelease isCompatibleWithCurrentSystemVersion ifFalse: [(self confirm: 'The package you are about to install is not listed as being compatible with your image version (', SystemVersion current majorMinorVersion, '), so the package may not work properly. Do you still want to proceed with the install?') ifFalse: [^ self]]. myRelease := self installedReleaseOfMe. [Cursor wait showWhile: [ (SMInstaller forPackageRelease: aRelease) install. myRelease = self installedReleaseOfMe ifFalse: [self reOpen]. self noteChanged] ] on: Error do: [:ex | | msg | msg := ex messageText ifNil:[ex asString]. self informException: ex msg: ('Error occurred during install:\', msg, '\') withCRs].! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 03:58'! installedReleaseOfMe "Return the release of the installed package loader." ^squeakMap installedReleaseOf: (squeakMap packageWithId: '941c0108-4039-4071-9863-a8d7d2b3d4a3').! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/13/2004 17:07'! noteChanged packagesList := nil. selectedCategoryWrapper := nil. filters ifNil: [^self reOpen]. self changed: #categoryWrapperList. self changed: #packageWrapperList. self changed: #packagesListIndex. "update my selection" self contentsChanged! ! !SMLoader methodsFor: 'private' stamp: 'gk 11/18/2003 02:24'! packages "We request the packages as sorted by name by default." ^squeakMap packagesByName asArray ! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/11/2004 04:06'! reOpen "Close this package loader, probably because it has been updated, and open a new one." self inform: 'This package loader has been upgraded and will be closed and reopened to avoid strange side effects.'. self delete. SMLoader open! ! !SMLoader methodsFor: 'private' stamp: 'gk 11/16/2003 20:12'! selectedPackageOrRelease "Return selected package or package release." ^(self selectedItemWrapper isNil) ifFalse: [self selectedItemWrapper withoutListWrapper]! ! !SMLoader methodsFor: 'private' stamp: 'gk 7/14/2004 17:15'! upgradeInstalledPackagesConfirm: confirmEach "Tries to upgrade all installed packages to the latest published release for this version of Squeak. If confirmEach is true we ask for every upgrade." | installed old myRelease toUpgrade info | installed _ squeakMap installedPackages. old _ squeakMap oldPackages. old isEmpty ifTrue: [ ^self inform: 'All ', installed size printString, ' installed packages are up to date.']. toUpgrade _ squeakMap upgradeableAndOldPackages. toUpgrade isEmpty ifTrue: [ ^self inform: 'None of the ', old size printString, ' old packages of the ', installed size printString, ' installed can be automatically upgraded. You need to upgrade them manually.']. old size < toUpgrade size ifTrue: [ info _ 'Of the ', old size printString, ' old packages only ', toUpgrade size printString, ' can be upgraded. The following packages will not be upgraded: ', (String streamContents: [:s | (old removeAll: toUpgrade; yourself) do: [:p | s nextPutAll: p nameWithVersionLabel; cr]])] ifFalse: [info _ 'All old packages upgradeable.']. (self confirm: info, ' About to upgrade the following packages: ', (String streamContents: [:s | toUpgrade do: [:p | s nextPutAll: p nameWithVersionLabel; cr]]), 'Proceed?') ifTrue: [ myRelease _ self installedReleaseOfMe. [Cursor wait showWhile: [ confirmEach ifTrue: [ squeakMap upgradeOldPackagesConfirmBlock: [:p | self confirm: 'Upgrade ', p installedRelease packageNameWithVersion, ' to ', (p lastPublishedReleaseForCurrentSystemVersionNewerThan: p installedRelease) listName, '?']] ifFalse: [squeakMap upgradeOldPackages]. self inform: toUpgrade size printString, ' packages successfully processed.'. myRelease = self installedReleaseOfMe ifFalse: [self reOpen]. self noteChanged] ] on: Error do: [:ex | self informException: ex msg: ('Error occurred when upgrading old packages:\', ex messageText, '\') withCRs]]! ! !SMLoader methodsFor: 'initialization' stamp: 'gk 7/12/2004 14:42'! on: aSqueakMap | | squeakMap := aSqueakMap. filters := DefaultFilters copy. categoriesToFilterIds := DefaultCategoriesToFilterIds copy. self loadUpdates! ! !SMLoader commentStamp: 'gk 11/18/2003 02:22' prior: 0! A simple package loader that is the standard UI for SqueakMap.! !SMLoader class methodsFor: 'interface opening' stamp: 'dvf 9/20/2002 20:53'! open "Create and open a SqueakMap Loader." "self open" (self new) createWindow; openInWorld! ! !SMLoader class methodsFor: 'interface opening' stamp: 'dvf 9/20/2002 20:53'! openOn: aSqueakMap "Create and open a SqueakMap Loader on a given map." "self openOn: SqueakMap default" (self newOn: aSqueakMap) createWindow; openInWorld! ! !SMLoader class methodsFor: 'private-publishing' stamp: 'yo 7/5/2004 20:21'! publish | pi versionNo packagedFileName packageFile sd initialPackagedFileName | pi _ PackageInfo named: 'SM-Loader'. versionNo := FillInTheBlank request: 'Version number for this file?'. pi fileOut. initialPackagedFileName := pi externalName,'.st'. packagedFileName _ pi externalName, '.', versionNo asString, (FileDirectory dot, FileStream cs). FileDirectory default rename: initialPackagedFileName toBe: packagedFileName. GZipWriteStream compressFile: packagedFileName. packageFile := FileDirectory default readOnlyFileNamed: packagedFileName. sd := ServerDirectory new. sd user: 'dvf'; server: 'modules.squeakfoundation.org'; password: (FillInTheBlank request: 'password?'); directory: 'Packages/'; putFile: packageFile named: packagedFileName! ! !SMLoader class methodsFor: 'menu registration' stamp: 'gk 7/11/2004 03:02'! initialize "Hook us up in the world menu." (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [ TheWorldMenu registerOpenCommand: {'SqueakMap Package Loader'. {self. #open}}. TheWorldMenu unregisterOpenCommand: 'Package Loader']. DefaultFilters _ OrderedCollection new. DefaultCategoriesToFilterIds _ OrderedCollection new ! ! !SMLoader class methodsFor: 'menu registration' stamp: 'gk 7/11/2004 03:08'! removeFromSystem self unload. super removeFromSystem! ! !SMLoader class methodsFor: 'menu registration' stamp: 'dew 7/7/2004 23:27'! unload (TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue: [TheWorldMenu unregisterOpenCommand: 'SqueakMap Package Loader'].! ! !SMLoader class methodsFor: 'instance creation' stamp: 'dvf 9/20/2002 20:52'! new "Create a browser on the default map." ^self newOn: SMSqueakMap default! ! !SMLoader class methodsFor: 'instance creation' stamp: 'dvf 9/20/2002 20:52'! newOn: aMap "Create a browser on ." ^super new on: aMap; yourself! ! !SMMcInstaller methodsFor: 'private' stamp: 'ab 8/13/2003 15:17'! fileIn | extension | extension _ (FileDirectory extensionFor: fileName) asLowercase. extension = 'mcz' ifTrue: [self installMcz] ifFalse: [self error: 'Cannot install file of type .', extension]! ! !SMMcInstaller methodsFor: 'private' stamp: 'ab 8/8/2003 18:33'! fullFileName ^ dir fullNameFor: fileName! ! !SMMcInstaller methodsFor: 'private' stamp: 'gk 7/13/2004 02:44'! installMcz "Install the package, we already know that either MCInstaller or Monticello is available." | installer monticello | installer := MczInstaller. (Smalltalk hasClassNamed: #MCMczReader) ifFalse: [ packageRelease package isInstalled ifTrue: [ (self silent ifFalse: [ (self confirm: 'A release of package ''', packageRelease package name, ''' is already installed. You only have MCInstaller and not Monticello installed and MCInstaller can not properly upgrade packages. Do you wish to install Monticello first and then proceed? If you answer no MCInstaller will be used - but at your own risk. Cancel cancels the installation.' orCancel: [self error: 'Installation cancelled.'])] ifTrue: [false]) ifTrue: [ monticello := packageRelease map packageWithName: 'Monticello'. monticello lastPublishedRelease ifNotNil: [monticello lastPublishedRelease install] ifNil: [monticello lastRelease install]. installer := (Smalltalk at: #MCMczReader)]] ] ifTrue: [installer := (Smalltalk at: #MCMczReader)]. installer loadVersionFile: self fullFileName! ! !SMMcInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'! install "This service should bring the package to the client, unpack it if necessary and install it into the image. The package is notified of the installation." self cache; fileIn. packageRelease noteInstalled! ! !SMMcInstaller commentStamp: 'gk 10/8/2003 14:28' prior: 0! I am a SMInstaller that knows how to install .mcz (Monticello) files. If Monticello is installed I use that (MCMczReader), otherwise I file in the code more simply using the package MCInstaller (MczInstaller).! !SMMcInstaller class methodsFor: 'testing' stamp: 'gk 11/14/2003 13:33'! canInstall: aPackage "Is this a Monticello package and do I have MCInstaller or Monticello available?" | fileName | ((Smalltalk includesKey: #MCMczReader) or: [ Smalltalk includesKey: #MczInstaller]) ifTrue: [ fileName _ aPackage downloadFileName. fileName ifNil: [^false]. ^ 'mcz' = (FileDirectory extensionFor: fileName) asLowercase]. ^false! ! !SMObject methodsFor: 'transactions' stamp: 'gk 6/6/2003 23:34'! changesFrom: originalObject on: stream "Store messagesends that express the difference compared to the given original on the stream." stream crtab; nextPutAll: 'updated:'. updated storeOn: stream. originalObject name = name ifFalse:[ stream nextPut: $;; crtab; nextPutAll: 'name: '. name storeOn: stream]. originalObject summary = summary ifFalse:[ stream nextPut: $;; crtab; nextPutAll: 'summary: '. summary storeOn: stream]. originalObject url = url ifFalse:[ stream nextPut: $;; crtab; nextPutAll: 'url: '. url storeOn: stream]! ! !SMObject methodsFor: 'transactions' stamp: 'gk 9/26/2003 00:05'! commit "Write a snapshot of the object to disk." ! ! !SMObject methodsFor: 'transactions' stamp: 'gh 12/1/2002 21:30'! definition "Return a String with a definition used for logging." self subclassResponsibility ! ! !SMObject methodsFor: 'transactions' stamp: 'gh 8/15/2002 08:38'! definition: isUpdate "Return a String with a definition used for logging." self subclassResponsibility ! ! !SMObject methodsFor: 'transactions' stamp: 'gh 12/2/2002 19:58'! definitionOn: stream "Stream out messages to create this object." stream crtab; nextPutAll: 'created: '. created storeOn: stream. stream nextPut: $;; crtab; nextPutAll: 'updated:'. updated storeOn: stream. stream nextPut: $;; crtab; nextPutAll: 'name: '. name storeOn: stream. stream nextPut: $;; crtab; nextPutAll: 'summary: '. summary storeOn: stream. stream nextPut: $;; crtab; nextPutAll: 'url: '. url storeOn: stream! ! !SMObject methodsFor: 'transactions' stamp: 'gk 9/26/2003 00:46'! endXMLOn: stream "Stream out endTag for this object." stream nextPutAll: ''! ! !SMObject methodsFor: 'transactions' stamp: 'gh 12/1/2002 20:25'! logDeleteOn: aStream "Log a deletion of me on the stream." aStream cr; nextChunkPut: 'self deleteObjectWithId: ', id asString storeString! ! !SMObject methodsFor: 'transactions' stamp: 'gk 9/26/2003 00:46'! startXMLOn: stream "Stream out startTag to create this object." stream nextPutAll: '';cr. stream nextPutAll: '<', self startTag, ' created="'. created storeOn: stream. stream nextPutAll: '" updated="'. updated storeOn: stream. stream nextPutAll: '" name="'. name storeOn: stream. stream nextPutAll: '" summary="'. summary storeOn: stream. stream nextPutAll: '" url="'. url storeOn: stream. stream nextPutAll: '">';cr! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'! created ^TimeStamp fromSeconds: created! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'! created: c created _ c! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'! createdAsSeconds ^created! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/16/2002 23:12'! id ^id! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:11'! id: anId id _ anId! ! !SMObject methodsFor: 'accessing' stamp: 'gh 8/15/2002 08:50'! map ^map! ! !SMObject methodsFor: 'accessing' stamp: 'gk 11/6/2003 14:46'! map: aMap map _ aMap! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:31'! name ^name! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:31'! name: aName name _ aName! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:33'! summary ^summary! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:33'! summary: aString summary _ aString! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:44'! updated ^TimeStamp fromSeconds: updated! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:44'! updated: c updated _ c! ! !SMObject methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:45'! updatedAsSeconds ^updated! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:36'! url ^url! ! !SMObject methodsFor: 'accessing' stamp: 'gh 6/26/2002 15:36'! url: aString url _ aString! ! !SMObject methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:21'! userInterface "Return the object that we use for interacting with the user." ^SMUtilities! ! !SMObject methodsFor: 'printing' stamp: 'gk 11/14/2003 14:22'! describe: string withBoldLabel: label on: stream "Helper method for doing styled text." stream withAttribute: (TextEmphasis bold) do: [ stream nextPutAll: label ]. stream nextPutAll: string; cr! ! !SMObject methodsFor: 'printing' stamp: 'gk 7/10/2004 03:39'! printName "Return a String identifying receiver without a context. Default is name." ^self name! ! !SMObject methodsFor: 'printing' stamp: 'gk 8/4/2003 11:56'! printOn: aStream aStream nextPutAll: self class name, '[', name, ']'! ! !SMObject methodsFor: 'printing' stamp: 'gk 11/14/2003 00:11'! type ^'Object'! ! !SMObject methodsFor: 'testing' stamp: 'gk 6/26/2003 16:47'! isAccount ^false! ! !SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'! isCategory ^false! ! !SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:40'! isPackage ^false! ! !SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'! isPackageRelease ^false! ! !SMObject methodsFor: 'testing' stamp: 'gh 12/1/2002 19:51'! isResource ^false! ! !SMObject methodsFor: 'updating' stamp: 'gk 9/24/2003 22:40'! stampAsUpdated "This method should be called whenever the object is modified." updated _ TimeStamp current asSeconds! ! !SMObject methodsFor: 'initialize-release' stamp: 'gk 9/23/2003 21:02'! initialize "Initialize the receiver." updated _ created _ TimeStamp current asSeconds. name _ summary _ url _ ''.! ! !SMObject methodsFor: 'initialize-release' stamp: 'gk 9/23/2003 21:02'! map: aMap id: anId "Initialize the receiver." self initialize. map _ aMap. id _ anId! ! !SMObject methodsFor: 'mail' stamp: 'gh 10/22/2002 16:49'! randomPhrase "Pick a nice phrase." ^#('Debug safely' 'Happy Squeaking' 'Just do it' 'Yours truly' 'Stay a Squeaker' 'Squeak rocks') atRandom! ! !SMObject methodsFor: 'logging' stamp: 'gh 8/15/2002 08:39'! logOn: aStream "Log me on the stream." aStream cr; nextChunkPut: (self definition: false)! ! !SMObject methodsFor: 'deletion' stamp: 'gk 8/8/2003 10:10'! delete "Delete from map." map deleteObject: self! ! !SMObject commentStamp: 'gk 9/23/2003 20:26' prior: 0! SMObject is the abstract superclass for all objects living in an SMSqueakMap. It has a unique UUID and a reference to the owning SMSqueakMap. It has timestamps to record the birthtime and the last modification. It has basic attributes like name, oneline summary and url. ! !SMObject class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 10:57'! newIn: aMap "Create a new object in a given map with an UUID to ensure unique identity." ^(self new) map: aMap id: UUID new! ! !SMObject class methodsFor: 'instance creation' stamp: 'nk 7/30/2004 10:56'! newIn: aMap withId: anUUIDString "Create a new object in a given SMSqueakMap with a given UUID as a String. This method is used when we create instances from a logfile etc." ^(self new) map: aMap id: (UUID fromString: anUUIDString)! ! !SMPackage methodsFor: 'accessing' stamp: 'gh 3/19/2002 20:11'! author ^author! ! !SMPackage methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:24'! author: aString author _ aString! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 16:05'! currentVersion ^self isPublished ifTrue: [self lastPublishedRelease version]! ! !SMPackage methodsFor: 'accessing' stamp: 'gh 3/19/2002 20:11'! description ^description! ! !SMPackage methodsFor: 'accessing' stamp: 'gh 3/17/2002 01:23'! description: aString description _ aString! ! !SMPackage methodsFor: 'accessing' stamp: 'btr 11/20/2003 00:30'! downloadUrl self isReleased ifFalse: [self error: 'There is no release for this package to download.']. ^self lastRelease downloadUrl! ! !SMPackage methodsFor: 'accessing' stamp: 'yo 7/28/2004 17:14'! fullDescription "Return a full textual description of the package. Most of the description is taken from the last release." | s publishedRelease | s := TextStream on: (Text new: 400). self describe: name withBoldLabel: 'Name: ' on: s. summary isEmptyOrNil ifFalse: [self describe: summary withBoldLabel: 'Summary: ' on: s ]. author isEmptyOrNil ifFalse: [s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Author:']; tab; tab. s withAttribute: (PluggableTextAttribute evalBlock: [self userInterface sendMailTo: (SMUtilities stripEmailFrom: author) regardingPackageRelease: self lastRelease]) do: [s nextPutAll: author]; cr]. self owner ifNotNil: [s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Owner:']; tab; tab. s withAttribute: (PluggableTextAttribute evalBlock: [self userInterface sendMailTo: self owner email regardingPackageRelease: self lastRelease]) do: [s nextPutAll: self owner nameAndEmail]; cr]. self maintainers isEmpty ifFalse: [ s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Co-maintainers:']; tab. self maintainers do: [:com | com = self maintainers first ifFalse: [s nextPutAll: ', ']. s withAttribute: (PluggableTextAttribute evalBlock: [self userInterface sendMailTo: com email regardingPackageRelease: self lastRelease]) do: [s nextPutAll: com nameAndEmail]]. s cr]. description isEmptyOrNil ifFalse: [s cr. s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Description:']. s cr. s withAttribute: (TextIndent tabs: 1) do: [s next: (description findLast: [ :c | c isSeparator not ]) putAll: description]. s cr ]. self describeCategoriesOn: s indent: 1. s cr. publishedRelease _ self lastPublishedRelease. self describe: (self publishedVersion ifNil: ['']) withBoldLabel: 'Published version: ' on: s. self isPublished ifTrue: [ s withAttribute: TextEmphasis bold do: [ s nextPutAll: 'Created: ' ]; print: publishedRelease created; cr. self note isEmptyOrNil ifFalse: [s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Release note:']. s cr. s withAttribute: (TextIndent tabs: 1) do: [s nextPutAll: publishedRelease note]. s cr ]]. url isEmptyOrNil ifFalse: [s cr; withAttribute: TextEmphasis bold do: [s nextPutAll: 'Homepage:']; tab; withAttribute: (TextURL new url: url) do: [s nextPutAll: url]; cr]. ^ s contents! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 1/25/2004 16:23'! maintainer "Deprecated" ^self owner! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 17:15'! note ^self isPublished ifTrue: [self lastPublishedRelease note]! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 11/6/2003 15:24'! packageInfoName ^packageInfoName! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 11/6/2003 15:24'! packageInfoName: aString packageInfoName _ aString! ! !SMPackage methodsFor: 'accessing' stamp: 'gk 7/12/2004 17:13'! publishedVersion ^self isPublished ifTrue: [self lastPublishedRelease version]! ! !SMPackage methodsFor: 'accessing' stamp: 'gh 12/1/2002 21:21'! releases ^releases! ! !SMPackage methodsFor: 'private' stamp: 'gk 10/15/2003 12:46'! addRelease: aRelease "Add the release." releases add: aRelease. aRelease package: self! ! !SMPackage methodsFor: 'private' stamp: 'gh 11/28/2002 21:25'! delete "Delete me. Delete my releases." super delete. self deleteReleases! ! !SMPackage methodsFor: 'private' stamp: 'gk 8/8/2003 10:01'! deleteReleases "Delete my releases." releases do: [:release | release delete]! ! !SMPackage methodsFor: 'private' stamp: 'gk 8/7/2003 21:28'! newRelease "Create a new release." ^releases addLast: (map newObject: (SMPackageRelease newInPackage: self))! ! !SMPackage methodsFor: 'private' stamp: 'gh 11/28/2002 21:33'! removeRelease: aRelease "Remove the release." releases remove: aRelease! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:11'! isAvailable "Answer if I am old or not installed regardless of if there is installer support for me. It also does not care if the newer release is not published or no for this Squeak version." ^self isOld or: [self isInstalled not]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 14:55'! isCached "Is the last release corresponding to me in the local file cache? NOTE: This doesn't honour #published nor if the release is intended for the current Squeak version." ^self isReleased and: [self lastRelease isCached]! ! !SMPackage methodsFor: 'testing' stamp: 'btr 11/20/2003 00:35'! isDownloadable "Answer if I can be downloaded." ^self isReleased and: [self lastRelease isDownloadable]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/15/2004 17:21'! isInstallable "Answer if any of my releases can be installed." ^ releases anySatisfy: [:rel | rel isInstallable]! ! !SMPackage methodsFor: 'testing' stamp: 'gh 10/25/2002 11:08'! isInstallableAndNotInstalled "Answer if there is any installer that can install me and I am not yet installed." ^self isInstallable and: [self isInstalled not]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 11/17/2003 11:02'! isInstalled "Answer if any version of me is installed." ^(map installedReleaseOf: self) notNil! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:10'! isOld "Answer if I am installed and there also is a newer version available *regardless* if it is not published or not for this Squeak version. This is for people who want to experiment!!" | installed | installed := map installedReleaseOf: self. ^installed ifNil: [false] ifNotNil: [ self releases anySatisfy: [:r | r newerThan: installed ]]! ! !SMPackage methodsFor: 'testing' stamp: 'gh 12/1/2002 19:40'! isPackage ^true! ! !SMPackage methodsFor: 'testing' stamp: 'gk 9/23/2003 21:35'! isPublished "Answer if I have public releases." ^releases anySatisfy: [:rel | rel isPublished]! ! !SMPackage methodsFor: 'testing' stamp: 'btr 11/20/2003 00:05'! isReleased ^ releases isEmpty not! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/13/2004 15:37'! isSafeToInstall "Answer if I am NOT installed and there also is a published version for this version of Squeak available." ^self isInstalled not and: [ self lastPublishedReleaseForCurrentSystemVersion notNil]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/14/2004 16:15'! isSafelyAvailable "Answer if I am old or not installed regardless of if there is installer support for me. The newer release should be published and meant for this Squeak version." ^self isSafeToInstall or: [self isSafelyOld]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/14/2004 17:16'! isSafelyOld "Answer if I am installed and there also is a newer published version for this version of Squeak available." | installed | installed _ self installedRelease. ^installed ifNil: [false] ifNotNil: [ ^(self lastPublishedReleaseForCurrentSystemVersionNewerThan: installed) notNil]! ! !SMPackage methodsFor: 'testing' stamp: 'gk 7/14/2004 17:16'! isSafelyOldAndUpgradeable "Answer if I am installed and there also is a newer published version for this version of Squeak available that can be upgraded to (installer support)." | installed newRelease | installed _ self installedRelease. ^installed ifNil: [false] ifNotNil: [ newRelease _ self lastPublishedReleaseForCurrentSystemVersionNewerThan: installed. ^newRelease ifNil: [false] ifNotNil: [newRelease isUpgradeable]]! ! !SMPackage methodsFor: 'testing' stamp: 'gh 10/25/2002 10:47'! isUpgradeableAndOld "Answer if there is any installer that can upgrade me and I can be upgraded." ^self isUpgradeable and: [self isOld]! ! !SMPackage methodsFor: 'testing' stamp: 'gh 10/25/2002 11:23'! isUpgradeableAndOldOrInstallableAndNotInstalled "Well, duh. Isn't it obvious? :-) Is the package available now for automatic install or automatic upgrade?" ^self isUpgradeableAndOld and: [self isInstallableAndNotInstalled]! ! !SMPackage methodsFor: 'testing-delegated' stamp: 'btr 11/20/2003 00:37'! isUpgradeable "Answer if there is any installer that can upgrade me." ^self isReleased and: [self lastRelease isUpgradeable]! ! !SMPackage methodsFor: 'cache' stamp: 'gk 8/12/2003 17:20'! cacheDirectory ^ self lastRelease cacheDirectory! ! !SMPackage methodsFor: 'cache' stamp: 'gk 3/8/2004 19:56'! download "Force download into cache." self isReleased ifFalse: [self error: 'There is no release for this package to download.']. ^self lastRelease download! ! !SMPackage methodsFor: 'cache' stamp: 'btr 11/20/2003 00:30'! ensureInCache "Makes sure the file is in the cache." self isReleased ifFalse: [self error: 'There is no release for this package to download.']. ^self lastRelease ensureInCache ! ! !SMPackage methodsFor: 'services' stamp: 'btr 11/20/2003 00:30'! downloadFileName "Cut out the filename from the url." self isReleased ifFalse: [self error: 'There is no release for this package to download.']. ^self lastRelease downloadFileName! ! !SMPackage methodsFor: 'services' stamp: 'gk 2/16/2004 20:14'! lastPublishedRelease "Return the latest published release." ^releases isEmpty ifTrue: [nil] ifFalse: [ releases reversed detect: [:r | r isPublished] ifNone:[nil]]! ! !SMPackage methodsFor: 'services' stamp: 'gk 7/13/2004 13:28'! lastPublishedReleaseForCurrentSystemVersion "Return the latest published release marked as compatible with the current SystemVersion." ^releases isEmpty ifTrue: [nil] ifFalse: [ releases reversed detect: [:r | r isPublished and: [r isCompatibleWithCurrentSystemVersion]] ifNone:[nil]]! ! !SMPackage methodsFor: 'services' stamp: 'gk 7/14/2004 17:15'! lastPublishedReleaseForCurrentSystemVersionNewerThan: aRelease "Return the latest published release marked as compatible with the current SystemVersion that is newer than the given release." ^releases isEmpty ifTrue: [nil] ifFalse: [ releases reversed detect: [:r | (r isPublished and: [r newerThan: aRelease]) and: [r isCompatibleWithCurrentSystemVersion]] ifNone:[nil]]! ! !SMPackage methodsFor: 'services' stamp: 'gk 8/4/2003 11:49'! lastRelease "Return the latest release." ^releases isEmpty ifTrue: [nil] ifFalse: [releases last]! ! !SMPackage methodsFor: 'services' stamp: 'gh 11/27/2002 12:33'! previousReleaseFor: aPackageRelease "If there is none, return nil." ^releases before: aPackageRelease ifAbsent: [nil]! ! !SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:39'! releaseWithAutomaticVersion: aVersion "Look up a specific package release of mine. Return nil if missing. They are few so we just do a #select:." ^releases detect: [:rel | rel automaticVersion = aVersion ] ifNone: [nil]! ! !SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:39'! releaseWithAutomaticVersionString: aVersionString "Look up a specific package release of mine. Return nil if missing. They are few so we just do a #select:." ^self releaseWithAutomaticVersion: aVersionString asVersion! ! !SMPackage methodsFor: 'services' stamp: 'gh 3/15/2003 18:50'! releaseWithId: anIdString "Look up a specific package release of mine. Return nil if missing. They are few so we just do a #select:." | anId | anId _ UUID fromString: anIdString. releases detect: [:rel | rel id = anId ]. ^nil! ! !SMPackage methodsFor: 'services' stamp: 'gk 11/18/2003 17:41'! releaseWithVersion: aVersionString "Look up a specific package release of mine. Return nil if missing. They are few so we just do a #select:." ^releases detect: [:rel | rel version = aVersionString ] ifNone: [nil]! ! !SMPackage methodsFor: 'services' stamp: 'gk 7/13/2004 14:37'! smartVersion "Delegate to last published release for this SystemVersion." | r | r := self lastPublishedReleaseForCurrentSystemVersion. ^r ifNotNil: [r smartVersion] ifNil: ['']! ! !SMPackage methodsFor: 'view' stamp: 'gh 7/30/2002 16:35'! getLink: aBuilder "Return a link for using on the web." ^aBuilder getLinkLocal: '/package/', id asString text: name! ! !SMPackage methodsFor: 'view' stamp: 'gh 3/15/2003 18:05'! viewFor: uiObject "This is a double dispatch mechanism for multiple views for multiple uis." ^uiObject packageViewOn: self! ! !SMPackage methodsFor: 'installation' stamp: 'gk 7/14/2004 17:32'! install "Install the latest newer published version for this version of Squeak." ^map installPackage: self! ! !SMPackage methodsFor: 'installation' stamp: 'gk 11/17/2003 02:27'! installedRelease "Return the installed release. We ask the map. Return nil if this package is not installed." ^map installedReleaseOf: self! ! !SMPackage methodsFor: 'installation' stamp: 'gk 11/17/2003 10:14'! installedVersion "Return the version String for the installed version. We ask the map. Return nil if this package is not installed." ^self installedRelease ifNotNilDo: [:r | r smartVersion]! ! !SMPackage methodsFor: 'installation' stamp: 'gk 11/18/2003 02:14'! nameWithVersionLabel ^name, ' (', self versionLabel, ')'! ! !SMPackage methodsFor: 'installation' stamp: 'gk 7/14/2004 17:31'! upgrade "Upgrade to the latest newer published version for this version of Squeak." | installed | installed _ self installedRelease. installed ifNil: [self error: 'No release installed, can not upgrade.'] ifNotNil: [^installed upgrade]! ! !SMPackage methodsFor: 'installation' stamp: 'gk 7/14/2004 17:43'! upgradeOrInstall "Upgrade to or install the latest newer published version for this version of Squeak." | installed | installed _ self installedRelease. installed ifNil: [^self install] ifNotNil: [^installed upgrade]! ! !SMPackage methodsFor: 'installation' stamp: 'gk 7/14/2004 17:16'! versionLabel "Return a label indicating installed and available version as: '1.0' = 1.0 is installed and no new published version for this version of Squeak is available '1.0->1.1' = 1.0 is installed and 1.1 is published for this version of Squeak '->1.1' = No version is installed and 1.1 is published for this version of Squeak '->(1.1) = No version is installed and there is only a non published version available for this version of Squeak The version showed is the one that #smartVersion returns. If a version name is in parenthesis it is not published." | installedVersion r r2 | r _ self installedRelease. r ifNotNil: [ installedVersion _ r smartVersion. r2 _ self lastPublishedReleaseForCurrentSystemVersionNewerThan: r] ifNil: [ installedVersion _ ''. r2 _ self lastPublishedReleaseForCurrentSystemVersion ]. ^r2 ifNil: [installedVersion ] ifNotNil: [installedVersion, '->', r2 smartVersion].! ! !SMPackage methodsFor: 'deprecated' stamp: 'btr 11/20/2003 00:23'! created: c updated: u name: n currentVersion: v summary: s description: d url: ur downloadUrl: du author: a maintainer: m registrator: r password: p categories: cats "Deprecated. Only kept for migration from SM 1.0x. Method used when recreating from storeOn: format. A few attributes are moved over from the card and the release is given the same categories as the card to begin with." self isReleased ifFalse:[self newRelease]. self lastRelease oldCreated: c updated: u downloadUrl: du maintainer: m registrant: r password: p version: v; categories: cats. self categories: cats. created _ c. updated _ u. name _ n. summary _ s. description _ d. url _ ur. author _ a ! ! !SMPackage methodsFor: 'deprecated' stamp: 'gh 11/27/2002 14:04'! downloadUrl: aString "Deprecated." self halt.! ! !SMPackage methodsFor: 'deprecated' stamp: 'btr 11/20/2003 00:38'! modulePath: p moduleVersion: v moduleTag: t versionComment: vc "Deprecated. Only kept for migration from SM 1.0x. Method used when recreating from storeOn: format." self isReleased ifTrue: [self lastRelease note: vc]! ! !SMPackage methodsFor: 'printing' stamp: 'gk 11/14/2003 00:12'! type ^'Package'! ! !SMPackage methodsFor: 'initialize-release' stamp: 'gk 3/8/2004 19:52'! initialize "Initialize package." super initialize. releases := OrderedCollection new! ! !SMPackage commentStamp: 'gh 11/22/2002 14:42' prior: 0! An SMCard is a library card describing a Squeak code package. It is the object representing a particular package and currently it has information about the current version available of the package. It contains a minimal amount of information as follows: name A String with a name for the package. The card has an id too so the name is not what makes the card unique. currentVersion A String with the readable version of the package. This can follow whatever style the author wants. summary A oneline String describing shortly what the package is in one sentence. description A 5-10 lines String describing the package in full. url A String with the url to the WWW homepage of the package if it has one. downloadUrl A String with the url to a download of the package. author A String with the original author in format 'Joe Schmoe '. maintainer A String with the current package maintainer in format 'Joe Schmoe '. registrator A String with the the person registrating the card in format 'Joe Schmoe '. password A String with the password that the registrator selected when registering the card. versionComment A String describing the specific version of the package. categories An OrderedCollection with the SMCategories that this card belongs to. Of all these variables only the last one - categories is not a simple String. When being stored or transmitted we use the UUIDs of the SMCategory objects instead and then "reconnect" them using real references.! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 11:22'! automaticVersion "Return the VersionNumber for me." ^automaticVersion! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gk 8/12/2003 17:21'! automaticVersionString "Return my VersionNumber as a String." ^automaticVersion versionString! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gk 8/13/2003 15:25'! cacheDirectory ^ map cache directoryForPackageRelease: self! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 14:03'! downloadFileName "Cut out the filename from the url." downloadUrl isEmpty ifTrue: [^nil]. ^downloadUrl asUrl path last! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:31'! downloadUrl ^downloadUrl! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:31'! downloadUrl: anObject ^downloadUrl := anObject! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:43'! note ^note! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 12:43'! note: anObject ^note := anObject! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 3/15/2003 20:55'! package "Get the package that I belong to." ^package! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gk 6/26/2003 14:59'! publisher ^publisher! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gk 6/26/2003 15:00'! publisher: anObject publisher := anObject! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:30'! version ^version! ! !SMPackageRelease methodsFor: 'accessing' stamp: 'gh 11/27/2002 15:30'! version: anObject ^version := anObject! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 8/13/2003 15:43'! download "Force a download into the cache regardless if it is already there." ^map cache download: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 7/13/2004 00:48'! eitherVersion "Return either version: 1. If the maintainer entered a version then we use that. 2. Otherwise we use the automatic version with an 'r' prepended." ^version notEmpty ifTrue:[version] ifFalse:['r', automaticVersion versionString]! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 7/10/2004 03:53'! ensureInCache "Makes sure the file is in the cache. Return true on success, otherwise false." ^map cache add: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 7/12/2004 16:04'! fullVersion "Return version followed by the automatic version with r prepended in parenthesis." ^version, ' (r', automaticVersion versionString, ')'! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 2/16/2004 20:04'! install "Install this package release." ^map installPackageRelease: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 11/17/2003 01:25'! noteInstalled "This package release was just successfully installed. We tell the map so that it can keep track of what package releases are installed." map noteInstalled: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 1/23/2004 10:01'! noteUninstalled "This package release was just successfully uninstalled. We tell the map so that it can keep track of what package releases are installed." self error: 'Uninstall is not working yet!!'. map noteUninstalled: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gh 11/27/2002 11:04'! previousRelease "Return the release before me. Returns nil if there is none." ^package previousReleaseFor: self! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 7/13/2004 00:49'! smartVersion "This method is used to ensure that we always have a version name for the package release even if the maintainer didn't bother to enter one. Is is calculated like this: 1. If the maintainer entered a version then we use that. 2. Otherwise we use the automatic version with an 'r' prepended. 3. If the release is not published we enclose it in parenthesis." ^ self isPublished ifTrue: [self eitherVersion] ifFalse: ['(', self eitherVersion, ')']! ! !SMPackageRelease methodsFor: 'services' stamp: 'gk 7/14/2004 17:42'! upgrade "Upgrade this package release if there is a new release available." | newRelease | newRelease _ package lastPublishedReleaseForCurrentSystemVersionNewerThan: self. newRelease ifNotNil: [(SMInstaller forPackageRelease: newRelease) upgrade]! ! !SMPackageRelease methodsFor: 'deletion' stamp: 'gh 11/28/2002 21:32'! delete super delete. package removeRelease: self! ! !SMPackageRelease methodsFor: 'initialize-release' stamp: 'btr 11/20/2003 00:41'! initializeInPackage: aPackage "Initialize package release. Currently we do not support branching so we simply pick the next available version number." | previous | self map: aPackage map id: UUID new. package _ aPackage. previous _ package lastRelease. automaticVersion _ previous ifNil: [VersionNumber first] ifNotNil: [previous automaticVersion next]. version _ note _ downloadUrl _ ''! ! !SMPackageRelease methodsFor: 'initialize-release' stamp: 'gk 8/8/2003 01:06'! oldCreated: c updated: u downloadUrl: du maintainer: m registrant: r password: p version: v "Deprecated. Only kept for migration from SM 1.0x. Method used when recreating from storeOn: format." created _ c. updated _ u. downloadUrl _ du. map findOrCreatePublisher: m password: p package: package. version _ v! ! !SMPackageRelease methodsFor: 'view' stamp: 'gk 1/19/2004 12:09'! getLink: aBuilder ^aBuilder getLinkLocal: '/package/', self package id asString, '/autoversion/', self automaticVersion versionString text: self packageNameWithVersion! ! !SMPackageRelease methodsFor: 'view' stamp: 'gk 1/19/2004 12:08'! getShortLink: aBuilder ^aBuilder getLinkLocal: '/package/', self package id asString, '/autoversion/', self automaticVersion versionString text: self listName! ! !SMPackageRelease methodsFor: 'view' stamp: 'gh 3/15/2003 19:37'! viewFor: uiObject "This is a double dispatch mechanism for multiple views for multiple uis." ^uiObject packageReleaseViewOn: self! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 8/13/2003 15:32'! isCached "Delegate to last release." ^map cache includes: self! ! !SMPackageRelease methodsFor: 'testing' stamp: 'dew 7/9/2004 00:18'! isCompatibleWithCurrentSystemVersion "Return true if this release is listed as being compatible with the SystemVersion of the current image. Only checks major/minor version number; does not differentiate between alpha/beta/gamma releases. Checks version categories of both the SMPackageRelease and the parent SMPackage." ^ (self categories, self package categories detect: [:cat | (cat parent name = 'Squeak versions') and: [(SystemVersion new version: cat name) majorMinorVersion = SystemVersion current majorMinorVersion]] ifNone: []) notNil ! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 10/15/2003 12:37'! isDownloadable "Answer if I can be downloaded. We simply verify that the download url ends with a filename." ^self downloadFileName isEmptyOrNil not! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 11/16/2003 23:48'! isInstallable "Answer if there is any installer for me. This depends typically on the filename of the download url, but can in the future depend on other things too. It does *not* say if the release is installed or not." ^SMInstaller isInstallable: self! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:59'! isInstalled "Answer if this release is installed." ^(map installedReleaseOf: package) == self! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gh 12/1/2002 19:52'! isPackageRelease ^true! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 9/23/2003 21:09'! isPublished "It is published when the publisher is set." ^publisher notNil! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 11/17/2003 12:01'! isUpgradeable "Answer if there is any installer that can upgrade me. This depends typically on the filename of the download url, but can in the future depend on other things too. It does *not* say if the package is installed or not or if there is a newer version available or not." ^SMInstaller isUpgradeable: self! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:24'! newerThan: aRelease "Answer if this release was made after ." ^aRelease automaticVersion < automaticVersion! ! !SMPackageRelease methodsFor: 'testing' stamp: 'gk 7/13/2004 13:24'! olderThan: aRelease "Answer if this release was made before ." ^automaticVersion < aRelease automaticVersion! ! !SMPackageRelease methodsFor: 'private' stamp: 'gh 11/27/2002 11:02'! package: aPackage "Set when I am created." package _ aPackage! ! !SMPackageRelease methodsFor: 'printing' stamp: 'yo 7/26/2004 22:06'! fullDescription "Return a full textual description of the package release." | s | s := TextStream on: (Text new: 400). self describe: self package name withBoldLabel: 'Package name: ' on: s. self describe: self version withBoldLabel: 'version: ' on: s. categories isEmptyOrNil ifFalse: [s cr; withAttribute: TextEmphasis bold do: [s nextPutAll: 'Categories: ']; cr. self categoriesDo: [:c | s tab; withAttribute: TextEmphasis italic do: [c parentsDo: [:p | s nextPutAll: p name; nextPutAll: '/']. s nextPutAll: c name]; nextPutAll: ' - ' , c summary; cr]. s cr]. self note isEmptyOrNil ifFalse: [s cr; withAttribute: TextEmphasis bold do: [s nextPutAll: 'Version Comment:']. s cr. s withAttribute: (TextIndent tabs: 1) do: [s nextPutAll: self note]. s cr; cr]. url isEmptyOrNil ifFalse: [s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Homepage:']; tab; withAttribute: (TextURL new url: url) do: [s nextPutAll: url]; cr]. self downloadUrl isEmptyOrNil ifFalse: [s withAttribute: TextEmphasis bold do: [s nextPutAll: 'Download:']; tab; withAttribute: (TextURL new url: self downloadUrl) do: [s nextPutAll: self downloadUrl]; cr]. ^s contents. ! ! !SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:35'! listName "Return something suitable for showing in lists. We list the manual version after a dash if it is available. We don't list the release name." ^version isEmpty ifFalse: [self automaticVersion versionString , '-', version] ifTrue: [self automaticVersion versionString] ! ! !SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:38'! packageNameWithVersion "Return ' -' like: 'SqueakMap 5-0.92' " ^package name, ' ', self listName! ! !SMPackageRelease methodsFor: 'printing' stamp: 'gk 7/10/2004 03:38'! printName "Return a String identifying object without context." ^self packageNameWithVersion! ! !SMPackageRelease methodsFor: 'printing' stamp: 'gk 12/9/2003 00:13'! printOn: aStream aStream nextPutAll: self class name, '[', self packageNameWithVersion, ']'! ! !SMPackageRelease methodsFor: 'printing' stamp: 'gk 11/14/2003 00:11'! type ^'Package release'! ! !SMPackageRelease commentStamp: 'gk 6/26/2003 15:22' prior: 0! Release-specific package information. This is autonumbered (with a VersionNumber) as well and has a designated version name which can be whatever the maintainer wants. The instvar publisher holds the name of the SMAccount that owned the package at the time of the release. This is for historic reasons. We don't reference the account itself because those may be deleted.! !SMPackageRelease class methodsFor: 'instance creation' stamp: 'gk 9/23/2003 20:33'! newInPackage: aPackage "Create a new release for a given package." ^super new initializeInPackage: aPackage! ! !SMPackageReleaseWrapper methodsFor: 'as yet unclassified' stamp: 'gk 7/13/2004 13:57'! asString "Show installed releases with a trailing asterisk." ^ item isInstalled ifTrue: [item smartVersion, ' *'] ifFalse: [item smartVersion]! ! !SMPackageReleaseWrapper methodsFor: 'as yet unclassified' stamp: 'gk 7/12/2004 17:32'! preferredEmphasis "Render the release as bold if it is published." ^item isPublished ifTrue: [1] ifFalse: [nil]! ! !SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:25'! = anObject ^self withoutListWrapper = anObject withoutListWrapper! ! !SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'gk 7/13/2004 00:34'! asString ^item nameWithVersionLabel! ! !SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 10/14/2003 18:58'! contents ^item releases reversed collect: [:e | SMPackageReleaseWrapper with: e]! ! !SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:25'! hash ^self withoutListWrapper hash! ! !SMPackageWrapper methodsFor: 'as yet unclassified' stamp: 'dvf 9/21/2003 16:22'! printOn: aStream aStream nextPutAll: 'wrapper for: ', item printString! ! !SMPersonalObject methodsFor: 'accessing' stamp: 'gk 8/7/2003 20:57'! maintainers "Return all maintainers." ^maintainers ifNil: [#()]! ! !SMPersonalObject methodsFor: 'accessing' stamp: 'gk 8/7/2003 20:56'! owner ^owner! ! !SMPersonalObject methodsFor: 'accessing' stamp: 'gk 8/7/2003 20:56'! owner: anAccount owner _ anAccount! ! !SMPersonalObject methodsFor: 'accessing' stamp: 'gk 11/6/2003 15:23'! rss ^rss! ! !SMPersonalObject methodsFor: 'accessing' stamp: 'gk 11/6/2003 15:22'! rss: anUrl rss _ anUrl! ! !SMPersonalObject methodsFor: 'deletion' stamp: 'gk 8/8/2003 02:27'! delete "Disconnect from owner and maintainers." super delete. owner removeObject: self. maintainers ifNotNil: [ maintainers copy do: [:m | self removeMaintainer: m]]! ! !SMPersonalObject methodsFor: 'maintainers' stamp: 'gk 11/11/2003 20:16'! addMaintainer: anAccount "Add anAccount as a maintainer." maintainers ifNil: [maintainers _ OrderedCollection new]. maintainers add: anAccount. anAccount addCoObject: self! ! !SMPersonalObject methodsFor: 'maintainers' stamp: 'avi 1/29/2004 02:48'! isOwnerOrMaintainer: anAccount ^ owner = anAccount or: [self maintainers includes: anAccount]! ! !SMPersonalObject methodsFor: 'maintainers' stamp: 'gk 11/11/2003 20:16'! removeMaintainer: anAccount "Remove anAccount as a maintainer." maintainers ifNil: [^self]. maintainers remove: anAccount. anAccount removeCoObject: self! ! !SMPersonalObject commentStamp: 'gk 9/23/2003 21:28' prior: 0! SMPersonalObject is the abstract base class for things that belong/are owned by a user account in SqueakMap. Most things are personal objects - but the SMCategories aren't for example. A personal object has a reference to the SMAccount owning it. It also has a potential list of maintainers - other accounts that also can modify the object.! !SMProjectInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'! install "This service should bring the package to the client, unpack it if necessary and install it into the image. The package is notified of the installation." Project canWeLoadAProjectNow ifFalse: [self error: 'Can not load Project now, probably because not in Morphic.']. self cache. [[ ProjectLoading openFromDirectory: dir andFileName: fileName ] on: ProgressTargetRequestNotification do: [ :ex | ex resume ]] ensure: [packageRelease noteInstalled]! ! !SMProjectInstaller commentStamp: '' prior: 0! I am a SMInstaller that knows how to install .pr (Project) files.! !SMProjectInstaller class methodsFor: 'testing' stamp: 'nk 10/26/2002 15:55'! canInstall: aPackage "Answer if this class can install the package. We handle .pr files (upper and lowercase)" | fileName | fileName _ aPackage downloadFileName. fileName ifNil: [^false]. ^'pr' = (FileDirectory extensionFor: fileName) asLowercase! ! !SMResource methodsFor: 'accessing' stamp: 'gk 9/23/2003 21:55'! version ^ version! ! !SMResource methodsFor: 'accessing' stamp: 'gk 9/23/2003 21:55'! version: aVersion version _ aVersion! ! !SMResource methodsFor: 'testing' stamp: 'btr 5/28/2003 04:25'! isResource ^ true! ! !SMResource commentStamp: 'gk 9/23/2003 21:54' prior: 0! A resource is a document that is NOT a package. Thus, it is used for all the things interesting to register on SM that aren't packages. The are three major differences with resources: - A resource keeps no track of version history like packages do with package releases. It only has a field for the current version. - A resource can be embedded inside the map instead of being a document reached by a URL. - A resource can be associated with another SMObject, the subject. However, resources respond to some of the same actions as PackageReleases.! !SMResource class methodsFor: 'instance creation' stamp: 'btr 5/28/2003 04:31'! forString: aString ^ SMEmbeddedResource new content: aString! ! !SMResource class methodsFor: 'instance creation' stamp: 'btr 5/28/2003 04:30'! forUrl: anUrl ^ SMExternalResource new downloadUrl: anUrl; yourself! ! !SMSARInstaller methodsFor: 'private' stamp: 'gh 10/31/2002 11:19'! fileIn Smalltalk at: #SARInstaller ifPresentAndInMemory: [:installer | (installer directory: dir fileName: fileName) fileIn. ^self]. self error: 'SAR support not installed in image, can not install.'! ! !SMSARInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 21:55'! install "This service should bring the package to the client, unpack it if necessary and install it into the image. The package is notified of the installation." self cache; fileIn. packageRelease noteInstalled! ! !SMSARInstaller commentStamp: '' prior: 0! I am a SqueakMap installer that knows how to deal with Zip format change-set archives. I recognize them by the file extension ".sar" (Squeak Archive). These have a couple of members with special names: install/preamble install/postscript These are loaded in order. Either or both can further load other members using fileInMemberNamed:. Inside a postscript or preamble, the pseudo-variable "self" is set to an instance of SARInstaller; you can then get to its ZipArchive using the method "zip". Or you can call its methods for filing in change sets, extracting files, etc. You can test this loading with: (SMSARInstaller new) directory: FileDirectory default; fileName: 'test.sar'; fileIn. See ChangeSet>>fileOutAsZipNamed: for one way to make these files. Here is another way of creating a multi change set archive installable by SqueakMap: "The following doit will create a .sar file with HVs preamble and postscript as separate entries and the included changesets included as normal. Given a preamble as described below this will autoinstall in SqueakMap." (ChangeSorter changeSetNamed: 'HV') fileOutAsZipNamed: 'httpview-021023.sar' including: { ChangeSorter changeSetNamed: 'HVFixes'. ChangeSorter changeSetNamed: 'kom412'} Preamble in changeset HV that will install the changesets: "Change Set: HV Date: 23 October 2002 Author: Göran Hultgren This is my latest developer code drop of HttpView packaged as a Squeak selfextracting archive (courtesy Ned Konz)." "Standard SqueakMap installing code follows:" (self isKindOf: SARInstaller) ifTrue:[ self fileInMemberNamed: 'HVFixes'. self fileInMemberNamed: 'kom412'. self fileInMemberNamed: 'HV' ] ! !SMSARInstaller class methodsFor: 'testing' stamp: 'gh 10/31/2002 10:03'! canInstall: aPackage "Answer if this class can install the package. We handle it if the filename has the extension .sar (upper and lowercase) and SARInstaller is present in the image to handle the install." | fileName | fileName _ aPackage downloadFileName. fileName ifNil: [^false]. Smalltalk at: #SARInstaller ifPresentAndInMemory: [ :installer | ^'sar' = (FileDirectory extensionFor: fileName) asLowercase]. ^false! ! !SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/23/2002 10:54'! directory ^dir! ! !SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/21/2002 14:39'! fileName ^fileName! ! !SMSimpleInstaller methodsFor: 'accessing' stamp: 'gk 8/13/2003 16:07'! fileName: aFileName fileName _ aFileName! ! !SMSimpleInstaller methodsFor: 'accessing' stamp: 'nk 2/22/2004 13:12'! fullFileName ^ self directory fullNameFor: self fileName! ! !SMSimpleInstaller methodsFor: 'accessing' stamp: 'gh 10/21/2002 14:39'! unpackedFileName ^unpackedFileName! ! !SMSimpleInstaller methodsFor: 'services' stamp: 'gk 11/16/2003 20:52'! cache "Download object into cache if needed. Set the directory and fileName for subsequent unpacking and install." packageRelease ensureInCache ifTrue: [ fileName _ packageRelease downloadFileName. dir _ packageRelease cacheDirectory]! ! !SMSimpleInstaller methodsFor: 'services' stamp: 'gk 11/17/2003 00:07'! download "This service downloads the last release of the package even if it is in the cache already." packageRelease download ifTrue: [ fileName _ packageRelease downloadFileName. dir _ packageRelease cacheDirectory]! ! !SMSimpleInstaller methodsFor: 'services' stamp: 'gk 7/13/2004 02:41'! fileIntoChangeSetNamed: aString fromStream: stream "We let the user confirm filing into an existing ChangeSet or specify another ChangeSet name if the name derived from the filename already exists." | changeSet newName oldChanges global | newName := aString. changeSet := SMInstaller changeSetNamed: newName. changeSet ifNotNil: [ newName := self silent ifNil: [FillInTheBlank request: 'ChangeSet already present, just confirm to overwrite or enter a new name:' initialAnswer: newName] ifNotNil: [newName]. newName isEmpty ifTrue:[self error: 'Cancelled by user']. changeSet := SMInstaller changeSetNamed: newName]. changeSet ifNil:[changeSet := SMInstaller basicNewChangeSet: newName]. changeSet ifNil:[self error: 'User did not specify a valid ChangeSet name']. oldChanges := (SystemVersion current highestUpdate < 5302) ifFalse: [global := ChangeSet. ChangeSet current] ifTrue: [global := Smalltalk. Smalltalk changes]. [global newChanges: changeSet. stream fileInAnnouncing: 'Loading ', newName, ' into change set ''', newName, ''''. stream close] ensure: [global newChanges: oldChanges]! ! !SMSimpleInstaller methodsFor: 'services' stamp: 'gk 9/30/2003 16:33'! unpack "This basic installer simply checks the file extension of the downloaded file to choose suitable method for unpacking. Currently it only supports .gz decompression. If a file exists with the same name it is first deleted. The unpacked filename is set on succesfull decompression or if the file was not recognized as a compressed file." | unzipped zipped buffer | (fileName endsWith: '.gz') ifTrue:[ unpackedFileName _ fileName copyUpToLast: FileDirectory extensionDelimiter. (dir fileExists: unpackedFileName) ifTrue:[ dir deleteFileNamed: unpackedFileName ]. unzipped _ dir newFileNamed: unpackedFileName. unzipped binary. zipped _ GZipReadStream on: (dir readOnlyFileNamed: fileName). buffer _ ByteArray new: 50000. 'Extracting ' , fileName displayProgressAt: Sensor cursorPoint from: 0 to: zipped sourceStream size during: [:bar | [zipped atEnd] whileFalse: [bar value: zipped sourceStream position. unzipped nextPutAll: (zipped nextInto: buffer)]. zipped close. unzipped close]] ifFalse:[unpackedFileName _ fileName]! ! !SMSimpleInstaller commentStamp: '' prior: 0! This is a base class that you can subclass if your package format can be downloaded using a single file url and possibly also be decompressed using gzip.! !SMSimpleInstaller class methodsFor: 'testing' stamp: 'gh 10/22/2002 11:55'! canInstall: aPackage "Answer if this class can install the package. This class is abstract so we return false." ^false! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/4/2003 11:50'! accountForEmail: email "Find account given email." ^self accounts detect: [:a | a email = email] ifNone: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/5/2003 10:59'! accountForName: name "Find account given full name. Disregarding case and allows up to 2 different characters. Size must match though, someone else can be smarter - this is just for migrating accounts properly." | lowerName size aName | lowerName _ name asLowercase. size _ lowerName size. ^self accounts detect: [:a | aName _ a name asLowercase. (aName size = size) and: [| errors | errors _ 0. aName with: lowerName do: [:c1 :c2 | c1 ~= c2 ifTrue: [errors _ errors + 1]]. errors < 3 ]] ifNone: [nil] ! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 7/30/2003 14:11'! accountForUsername: username "Find account given username. The username used is the developer initials of the account." ^self users at: username ifAbsent: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/4/2003 16:30'! accountWithId: anIdString "Look up an account. Return nil if missing. Raise error if it is not an account." | account | account _ self objectWithId: anIdString. account ifNil: [^nil]. account isAccount ifTrue:[^account]. self error: 'UUID did not map to a account.'! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 2/7/2004 14:55'! accountWithName: aName "Look up an account by name. Return nil if missing." ^self accounts values detect: [:a | a name = aName ] ifNone: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/4/2003 17:03'! accountsByInitials "Return the accounts sorted by the developer initials." ^(SortedCollection sortBlock: [:x :y | x initials <= y initials]) addAll: self accounts; yourself! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 8/4/2003 17:00'! accountsByName "Return the accounts sorted by their name." ^(SortedCollection sortBlock: [:x :y | x name <= y name]) addAll: self accounts; yourself! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 20:10'! categoryWithId: anIdString "Look up a category. Return nil if missing. Raise error if it is not a category." | cat | cat _ self objectWithId: anIdString. cat ifNil: [^nil]. cat isCategory ifTrue:[^cat]. self error: 'UUID did not map to a category.'! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/11/2003 18:31'! categoryWithNameBeginning: aString "Look up a category beginning with . Return nil if missing. We return the shortest matching one. We also strip out spaces and ignore case in both and the names." | candidates shortest answer searchString | searchString _ (aString asLowercase) copyWithout: Character space. candidates _ self categories select: [:cat | ((cat name asLowercase) copyWithout: Character space) beginsWith: searchString ]. shortest _ 1000. candidates do: [:ca | ca name size < shortest ifTrue:[answer _ ca. shortest _ ca name size]]. ^answer ! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/18/2003 02:06'! object: aUUID "Look up a categorizable object. Return nil if missing." ^objects at: aUUID ifAbsent: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:25'! objectWithId: anIdString "Look up a categorizable object. Return nil if missing." ^objects at: (UUID fromString: anIdString) ifAbsent: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/17/2003 23:25'! packageReleaseWithId: anIdString "Look up a package release. Return nil if missing. Raise error if it is not a package release." | r | r _ self objectWithId: anIdString. r ifNil: [^nil]. r isPackageRelease ifTrue:[^r]. self error: 'UUID did not map to a package release.'! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:39'! packageWithId: anIdString "Look up a package. Return nil if missing. Raise error if it is not a package." | package | package _ self objectWithId: anIdString. package ifNil: [^nil]. package isPackage ifTrue:[^package]. self error: 'UUID did not map to a package.'! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:54'! packageWithName: aName "Look up a package by exact match on name. Return nil if missing." ^self packages detect: [:package | package name = aName ] ifNone: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:54'! packageWithNameBeginning: aString "Look up a package beginning with . Return nil if missing. We return the shortest matching one. We also strip out spaces and ignore case in both and the names." | candidates shortest answer searchString | searchString _ (aString asLowercase) copyWithout: Character space. candidates _ self packages select: [:package | ((package name asLowercase) copyWithout: Character space) beginsWith: searchString ]. shortest _ 1000. candidates do: [:package | package name size < shortest ifTrue:[answer _ package. shortest _ package name size]]. ^answer ! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gk 11/11/2003 18:37'! packageWithPI: aPIName "Look up a package by exact match on PackageInfo name. Return nil if missing." aPIName isEmptyOrNil ifTrue: [^nil]. ^self packages detect: [:package | package packageInfoName = aPIName ] ifNone: [nil]! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 19:54'! packagesByName "Return the packages sorted by their name." ^(SortedCollection sortBlock: [:x :y | x name <= y name]) addAll: self packages; yourself! ! !SMSqueakMap methodsFor: 'queries' stamp: 'gh 12/1/2002 20:12'! topCategories ^self categories select: [:cat | cat isTopCategory]! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gh 8/15/2002 08:34'! addCategory: aCategory "Add a new category. Log it in the logfile." self log: aCategory. ^categories at: aCategory id put: aCategory! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 10:30'! addCategory: category inObject: object "Add a category in an object." ^object addCategory: category ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 2/7/2004 14:56'! addObject: anSMObject "Add a new object, only if not already added." (self object: anSMObject id) ifNil: [ self transaction: [self newObject: anSMObject]]! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gh 11/28/2002 20:44'! changeCategoriesTo: newCategories inObject: object "Remove or add categories in an object such that it belongs to the categories in . Logs the changes." newCategories do: [:cat | (object hasCategory: cat) ifFalse:[self addCategory: cat inObject: object]]. object categories do: [:cat | (newCategories includes: cat) ifFalse: [self removeCategory: cat inObject: object]] ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 14:56'! moveCategory: category toAfter: categoryBefore inParent: parent "Move a category to be listed after in ." parent move: category toAfter: categoryBefore. ^category ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 5/22/2004 22:22'! moveCategory: category toParent: parentCategory "Move a category into another parent category." parentCategory ifNil: [category parent: nil] ifNotNil: [parentCategory addCategory: category]. ^category ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 8/4/2003 16:01'! newAccount: name username: username email: email "Create an account. Checking for previous account should already have been done. To add the account to the map, use SMSqueakMap>>addObject:" | account | account _ self newAccount name: name; initials: username; email: email. ^account ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 9/24/2003 22:54'! removeCategory: aCategory "Remove a category. Same as deleting it but we log it too." self halt. self deleteCategory: aCategory. self logDelete: aCategory. ^aCategory! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 11/17/2003 10:30'! removeCategory: category inObject: object "Remove a category from an object." ^object removeCategory: category ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gk 8/8/2003 10:00'! removeObject: anObject "Delete it and log it in the logfile." anObject delete. self logDelete: anObject. ^anObject ! ! !SMSqueakMap methodsFor: 'public-master' stamp: 'gh 8/2/2002 01:32'! removeRepository: aRepository "Log it in the logfile and delete it." self deleteRepository: aRepository. self logDelete: aRepository. ^aRepository! ! !SMSqueakMap methodsFor: 'private' stamp: 'gh 10/31/2002 11:59'! checkVersion: string "Check the content for a SqueakMap version conflict notification. Return true if no conflict is reported, otherwise ask user if we should upgrade SqueakMap using the bootstrap method." (string beginsWith: 'Server version:') ifTrue:[(self confirm: ('The SqueakMap master server is running another version (', (string last: (string size - 15)), ') than the client (', SMSqueakMap version, '). You need to upgrade the SqueakMap package, would you like to do that now?')) ifTrue: [self class bootStrap. ^false] ifFalse: [^false] ]. ^true! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/18/2003 00:18'! clearCaches "Clear the caches." packages _ accounts _ users _ categories _ nil ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/8/2003 19:09'! clearCachesFor: anObject "Clear the valid caches." anObject isPackage ifTrue:[packages _ nil]. anObject isAccount ifTrue:[accounts _ users _ nil]. anObject isCategory ifTrue:[categories _ nil] ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/8/2003 19:08'! clearUsernames "Clear the username cache." users _ nil! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/14/2003 14:01'! copyFrom: aMap "Copy all relevant info from the other map." objects _ aMap objects. objects do: [:o | o map: self]. accounts _ users _ packages _ categories _ nil. checkpointNumber _ aMap checkpointNumber.! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 7/14/2003 23:52'! countInstall "Increase the install counter." installCounter ifNil: [installCounter _ 0]. ^installCounter _ installCounter + 1 ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/14/2003 11:53'! deleteCategory: cat "Delete a category. Remove it and all its subCategories from all objects. Remove the category from its parent. Finally remove them all from my collections." cat removeDeepFromObjects. cat removeFromParent. cat allCategoriesDo: [:c | categories removeKey: c id ]. ^cat ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/8/2003 19:10'! deleteObject: anObject "Delete an object, remove it from objects. This method is called from the #delete method of anObject so it will take care of the rest of the cleaning up. Clear the valid caches." objects removeKey: anObject id. self clearCachesFor: anObject ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/4/2003 15:22'! emailOccupied: aUsername "Return true if email already taken." ^(self accountForEmail: aUsername) notNil! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/8/2003 02:09'! findOrCreatePublisher: pub password: password package: aPackage "Find or create an account. Password will be the first one." | email name account | email _ SMUtilities stripEmailFrom: pub. name _ SMUtilities stripNameFrom: pub. account _ self accountForEmail: email. account ifNil: ["none found, try searching on name too..." account _ self accountForName: name]. account ifNotNil: [account addObject: aPackage] ifNil: ["Ok, create it" account _ self newAccount name: name; email: email; password: password. account addObject: aPackage. self newObject: account. account]. ^account ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 10/2/2003 10:24'! isLogFileAvailable "Check that there is an 'sm' directory and that it contains at least one logfile." [self logFileName] on: Error do: [:ex | ^false]. ^true! ! !SMSqueakMap methodsFor: 'private' stamp: 'ls 8/23/2003 16:01'! lastTransactionInLog "Find the last transaction number in the current logfile." | file | [ file _ self openLogFileReadOnly setToEnd. #('self transactionCounter:' 'self firstTransactionNumber:') do: [:key | (file findStringFromEnd: key) = 0 ifFalse: [ file skip: key size. ^(file upTo: $!!) withBlanksTrimmed asNumber ]] ] ensure: [file close]. ^0 "No marker found" ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/17/2003 23:15'! loadFullFrom: aServerName "Contact the SqueakMap at the url and load a full map from scratch." | url zipped | url _ 'http://', aServerName, '/sm/loadgz?mapversion=', SMSqueakMap version, '&checkpoint=', checkpointNumber asString. Transcript show: 'Fetch: ', (Time millisecondsToRun: [ zipped _ (HTTPSocket httpGet: url) contents]) asString, ' ms';cr. Transcript show: 'Size: ', zipped size asString, ' bytes';cr. ((self checkVersion: zipped) and: [zipped ~= 'UPTODATE']) ifTrue:[ Transcript show: 'Save checkpoint to disk: ', (Time millisecondsToRun: [ self saveCheckpoint: zipped]) asString, ' ms';cr. Transcript show: 'Full reload from checkpoint: ', (Time millisecondsToRun: [ self reload]) asString, ' ms';cr.]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/14/2003 00:52'! loadUpdatesFrom: aServerName "Contact the SqueakMap at the url and load needed updates from it based on our last known transaction number which we send as an urlencoded argument. If the master answers 'DO FULL!!' we issue a full load instead. If the master answers 'STALE SERVER!!' we notify the user and bail out." | url zipped updates | url _ 'http://', aServerName, '/sm/updatesgz?mapversion=', '1.0', '&transaction=', transactionCounter asString. Transcript show: 'Fetch: ', (Time millisecondsToRun: [ zipped _ (HTTPSocket httpGet: url) contents]) asString, ' ms';cr. Transcript show: 'Size: ', zipped size asString, ' bytes';cr. Transcript show: 'Decompress time: ', (Time millisecondsToRun: [updates _ (GZipReadStream on: zipped) upToEnd]) asString, ' ms';cr. (self checkVersion: updates) ifTrue:[ updates = 'STALE SERVER!!' ifTrue:[ self inform: 'Server ', aServerName printString, ' is stale!! Aborting update.'. ^self]. updates = 'DO FULL!!' ifTrue:[ Transcript show: 'Master can not deliver updates this far back, falling back on full load.';cr. ^self loadFullFrom: aServerName]. Transcript show: 'Load updates with logging time: ', (Time millisecondsToRun: [self loadUpdatesFrom: (ReadStream on: updates) log: true]) asString, ' ms';cr.]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 10/10/2003 13:25'! loadUpdatesFull: full "Find a server and load updates from it." | server | server _ self class findServer. server ifNotNil: [ self synchWithDisk. full ifTrue: [self loadFullFrom: server] ifFalse:[self error: 'Not supported yet!!'."self loadUpdatesFrom: server"]]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/17/2003 22:57'! mandatoryCategoriesFor: aClass "Return the categories that are mandatory for instances of ." ^self categories select: [:c | c mandatoryFor: aClass]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/3/2003 23:23'! newAccount "Create a new account." ^SMAccount newIn: self! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 9/26/2003 00:04'! newObject: anSMObject "Add an SMObject to me. Clear the valid caches." self addDirty: anSMObject. self clearCachesFor: anSMObject. ^objects at: anSMObject id put: anSMObject! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/3/2003 23:24'! newPackage "Create a new package." ^SMPackage newIn: self! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/14/2003 00:53'! oldLoadFullFrom: aServerName "Contact the SqueakMap at the url and load a full map from scratch." | url zipped full | url _ 'http://', aServerName, '/sm/loadgz?mapversion=', '1.0'. Transcript show: 'Fetch: ', (Time millisecondsToRun: [ zipped _ (HTTPSocket httpGet: url) contents]) asString, ' ms';cr. Transcript show: 'Size: ', zipped size asString, ' bytes';cr. Transcript show: 'Decompress time: ', (Time millisecondsToRun: [full _ (GZipReadStream on: zipped) upToEnd]) asString, ' ms';cr. (self checkVersion: full) ifTrue:[ Transcript show: 'Save full log: ', (Time millisecondsToRun: [ self createNewLogWithInitialContent: full]) asString, ' ms';cr. Transcript show: 'Full reload from log: ', (Time millisecondsToRun: [ self reloadLog]) asString, ' ms';cr.]! ! !SMSqueakMap methodsFor: 'private' stamp: 'btr 5/28/2003 00:56'! packageCacheDirectoryName "What is the name of the cache directory?" ^'cache'! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 9/30/2003 17:03'! pingServer: aServerName ^self class pingServer: aServerName! ! !SMSqueakMap methodsFor: 'private' stamp: 'gh 11/28/2002 22:19'! storeOn: aStream "Store the model condensed on the stream. First chunk is current date. Categories are saved first (in a top down manner so that loading will be able to resolve parents directly), then all the objects. At the end we tack on the last known transactionId." self topCategories do: [:cat | cat logRecursivelyOn: aStream]. objects valuesDo: [:package | package logOn: aStream]. self logFirstTransactionNumberOn: aStream! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 11/17/2003 23:15'! synchWithDisk "Synchronize myself with the checkpoints on disk. If there is a newer checkpoint than I know of, load it. If there is no checkpoint or if I have a higher checkpoint number, create a new checkpoint from me. The end result is that I am in synch with the disk and we are both as updated as possible." | checkpointNumberOnDisk | "If there is no checkpoint, save one from me." (self isCheckpointAvailable) ifFalse: [^self createCheckpointNumber: checkpointNumber]. "If the one on disk is newer, load it" checkpointNumberOnDisk _ self lastCheckpointNumberOnDisk. (checkpointNumber < checkpointNumberOnDisk) ifTrue: [^self reload]. "If I am newer, recreate me on disk" (checkpointNumberOnDisk < checkpointNumber) ifTrue: [^self createCheckpointNumber: checkpointNumber]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 10/2/2003 10:34'! synchWithLog "Synchronize myself with the current logfile. If the logfile has newer updates, load them. If the logfile can not produce updates as far back as I need, do a full reload. If the logfile does not exist or if I have newer updates than the logfile, create a new logfile from me. The end result is that I am in synch with the logfile and we are both as updated as possible." | updates | "If there is no logfile, create it from ourself." (self isLogFileAvailable) ifFalse: [self saveNewLog. ^self]. updates _ self updatesSinceTransactionInLog: transactionCounter. updates = '' ifTrue: [^self]. "Already in synch." updates = 'DO FULL!!' ifFalse: [ updates = 'STALE SERVER!!' ifTrue: [self saveNewLog] ifFalse: [self loadUpdatesFrom: (ReadStream on: updates) log: false]] ifTrue: [self reloadLog]! ! !SMSqueakMap methodsFor: 'private' stamp: 'gh 8/2/2002 14:31'! updatesSinceFirstTransaction "Produce a String with all recorded transactions from the logfile. We go to the beginning of the file, then we search for the text 'firstTransactionNumber: xxx'. Finally we return all transactions from then on. The implementation uses the new method #findString: which should be reasonably fast." | file found result key | [ file _ self openLogFileReadOnly. key _ 'self firstTransactionNumber:'. found _ file findString: key. found = 0 ifTrue:[result _ nil] ifFalse: [ file skip: key size; upTo: $!!; next. result _ file upToEnd ]] ensure: [file close]. ^result ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gh 10/21/2002 14:21'! updatesSinceTransaction: lastTransaction "Produce a String with all transactions from the logfile since . We go to the end of the file, then we search backwards for the text 'transactionCounter: xxx'. The implementation uses the new method #findStringFromEnd: which should be reasonably fast. If we find no such marker it means that this logfile has been condensed and does not have enough transactions to return, then we return 'DO FULL!!'. The client will have to ask for the whole file instead. If the server has a lower transaction counter than the one sent the server is stale, let the client know this." | file found result key | lastTransaction = transactionCounter ifTrue:[^'']. lastTransaction > transactionCounter ifTrue:[^'STALE SERVER!!']. lastTransaction = firstTransactionNumber ifTrue:[^self updatesSinceFirstTransaction ]. [ file _ self openLogFileReadOnly setToEnd. key _ 'self transactionCounter: ', lastTransaction storeString, '!!'. found _ file findStringFromEnd: key. found = 0 ifTrue:[result _ 'DO FULL!!'] ifFalse: [ file skip: key size. result _ file upToEnd ]] ensure: [file close]. ^result ! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 7/14/2003 01:21'! updatesSinceTransactionInLog: lastTransaction "Produce a String with all transactions from the logfile since . We go to the end of the file, then we search backwards for the text 'transactionCounter: xxx'. The implementation uses the new method #findStringFromEnd: which should be reasonably fast. If we find no such marker it means that this logfile has been condensed and does not have enough transactions to return, then we return 'DO FULL!!'. The client will have to ask for the whole file instead. If the server has a lower transaction counter than the one sent the server is stale, let the client know this. This method does not rely on the transactionCounter in the instance." | file found result key lastInLog | lastInLog _ self lastTransactionInLog. lastTransaction = lastInLog ifTrue:[^'']. lastTransaction > lastInLog ifTrue:[^'STALE SERVER!!']. lastTransaction = firstTransactionNumber ifTrue:[^self updatesSinceFirstTransaction ]. [ file _ self openLogFileReadOnly setToEnd. key _ 'self transactionCounter: ', lastTransaction storeString, '!!'. found _ file findStringFromEnd: key. found = 0 ifTrue:[result _ 'DO FULL!!'] ifFalse: [ file skip: key size. result _ file upToEnd ]] ensure: [file close]. ^result! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 8/3/2003 23:13'! usernameOccupied: aUsername "Return true if name already taken." ^(self accountForUsername: aUsername) notNil! ! !SMSqueakMap methodsFor: 'private' stamp: 'gk 10/21/2003 23:05'! verifyAdminPassword: aString "Answer true if it is the correct password." ^adminPassword = (SecureHashAlgorithm new hashMessage: aString)! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/19/2003 19:51'! clearInstalledPackageWithId: aPackageId "Clear the fact that any release of this package is installed. Can be used even when the map isn't loaded." ^installedPackages ifNotNil: [ installedPackages removeKey: (UUID fromString: aPackageId) ifAbsent: [nil]]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 01:23'! clearInstalledPackages "Simply clear the dictionary with information on installed packages. Might be good if things get corrupted etc. Also see SMSqueakMap class>>recreateInstalledPackagesFromChangeLog" installedPackages _ nil. installCounter _ 0! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 15:51'! installPackage: aPackage "Install the package. Note: This method should not be used anymore, better to specify a specific release." | rel | rel _ aPackage lastPublishedReleaseForCurrentSystemVersion ifNil: [self error: 'No published release for this system version found to install.']. ^self installPackageRelease: rel! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 1/15/2004 00:14'! installPackage: aPackage autoVersion: version "Install the release of is the automatic version name." | r | r _ aPackage releaseWithAutomaticVersionString: version. r ifNil: [self error: 'No package release found with automatic version ', version]. ^self installPackageRelease: r! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 2/12/2004 23:41'! installPackageLatestPublished: aPackage "Install the latest published release of the package." ^self installPackageRelease: aPackage lastPublishedRelease! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 2/12/2004 23:40'! installPackageLatestPublishedNamed: aString "Install the latest published release of the package with a name beginning with aString (see method comment of #packageWithNameBeginning:)." | p | p _ self packageWithNameBeginning: aString. p ifNil: [self error: 'No package found with name beginning with ', aString]. ^self installPackageLatestPublished: p! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 15:54'! installPackageNamed: aString "Install the last published release for this Squeak version of the package with a name beginning with aString (see method comment of #packageWithNameBeginning:). Note: This method should not be used anymore. Better to specify a specific release." | p | p _ self packageWithNameBeginning: aString. p ifNil: [self error: 'No package found with name beginning with ', aString]. ^self installPackage: p! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 23:35'! installPackageNamed: aString autoVersion: version "Install the release of the package with a name beginning with aString (see method comment of #packageWithNameBeginning:). is the automatic version name." | p r | p _ self packageWithNameBeginning: aString. p ifNil: [self error: 'No package found with name beginning with ', aString]. r _ p releaseWithAutomaticVersionString: version. r ifNil: [self error: 'No package release found with automatic version ', version]. ^self installPackageRelease: r! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 15:57'! installPackageRelease: aPackageRelease "Install the given package release, no checks made." (SMInstaller forPackageRelease: aPackageRelease) install! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 23:24'! installPackageReleaseWithId: anUUIDString "Look up and install the given release." | r | r _ self packageReleaseWithId: anUUIDString. r ifNil: [self error: 'No package release available with id: ''', anUUIDString, '''']. ^self installPackageRelease: r! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 23:30'! installPackageWithId: anUUIDString "Look up and install the latest release of the given package. Note: This method should not be used anymore. Better to specify a specific release." | package | package _ self packageWithId: anUUIDString. package ifNil: [self error: 'No package available with id: ''', anUUIDString, '''']. ^self installPackage: package! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 1/15/2004 00:15'! installPackageWithId: anUUIDString autoVersion: version "Install the release of the package with id . is the automatic version name." | p | p _ self packageWithId: anUUIDString. p ifNil: [self error: 'No package available with id: ''', anUUIDString, '''']. ^self installPackage: p autoVersion: version! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 1/18/2004 15:29'! installedPackageReleases "Answer all package releases that we know are installed. Lazily initialize. The Dictionary contains the installed packages using their UUIDs as keys and the version string as the value." ^self installedPackages collect: [:p | self installedReleaseOf: p]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 2/17/2004 13:05'! installedPackages "Answer all packages that we know are installed. Lazily initialize. The Dictionary contains the installed packages using their UUIDs as keys and the version string as the value." | result p | result _ OrderedCollection new. installedPackages ifNil: [#()] ifNotNil: [installedPackages keys do: [:k | p _ self object: k. p ifNotNil: [result add: p]]]. ^result! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2003 23:35'! installedPackagesDictionary "Access the dictionary directly. The UUID of the installed package is the key. The value is an OrderedCollection of Arrays. The arrays have the smartVersion of the package, the time of the installation in seconds and the sequence number (installCounter)." ^installedPackages ifNil: [Dictionary new]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/19/2003 20:05'! installedPackagesDictionary: aDict "Set dictionary directly." installedPackages _ aDict! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/19/2003 21:02'! installedReleaseOf: aPackage "If the package is installed, return the release. Otherwise return nil. SM2 stores the version as an Association to be able to distinguish it." | autoVersionOrOld | installedPackages ifNil: [^nil]. autoVersionOrOld _ (installedPackages at: aPackage id ifAbsent: [^nil]) last first. (autoVersionOrOld isKindOf: Association) ifTrue: [ ^aPackage releaseWithAutomaticVersion: autoVersionOrOld value] ifFalse: [ ^aPackage releaseWithVersion: autoVersionOrOld]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 1/23/2004 09:55'! installedVersionOf: aPackage "If the package is installed, return the version as a String. If it is a package installed during SM1 it will return the manual version String, for SM2 it returns the automatic version as a String. If package is not installed - return nil. If you want it to work without the map loaded you should instead use #installedVersionOfPackageWithId:." | versionOrString | versionOrString _ self installedVersionOfPackageWithId: aPackage id. versionOrString ifNil: [^nil]. ^versionOrString isString ifTrue: [versionOrString] ifFalse: [versionOrString versionString]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/19/2003 21:10'! installedVersionOfPackageWithId: anId "If the package is installed, return the automatic version or version String. Otherwise return nil. This can be used without the map loaded." | autoVersionOrOld | installedPackages ifNil: [^nil]. autoVersionOrOld _ (installedPackages at: anId ifAbsent: [^nil]) last first. (autoVersionOrOld isKindOf: Association) ifTrue: [ ^autoVersionOrOld value] ifFalse: [ ^autoVersionOrOld]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 17:49'! noteInstalled: aPackageRelease "The package release was just successfully installed using SM. This is the method being called by SM upon a successful installation. We record this in our Dictionary of installed package releases and log a 'do it' to mark this in the changelog. The map used is the default map." ^self noteInstalledPackageWithId: aPackageRelease package id asString autoVersion: aPackageRelease automaticVersion name: aPackageRelease package name! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 17:50'! noteInstalledPackage: aPackage autoVersion: aVersion "Mark that the package release was just successfully installed. Can be used to inform SM of an installation not been done using SM." ^self noteInstalledPackageWithId: aPackage id asString autoVersion: aVersion name: aPackage name! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 17:51'! noteInstalledPackageNamed: aString autoVersion: aVersion "Mark that the package release was just successfully installed. is the automatic version as a String. Can be used to inform SM of an installation not been done using SM." | p | p _ self packageWithNameBeginning: aString. p ifNil: [self error: 'No package found with name beginning with ', aString]. ^self noteInstalledPackage: p autoVersion: aVersion asVersion! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/18/2003 11:59'! noteInstalledPackageWithId: aPackageId autoVersion: aVersion "The package release was just successfully installed. Can be used to inform SM of an installation not been done using SM, even when the map isn't loaded." ^self noteInstalledPackageWithId: aPackageId autoVersion: aVersion name: ''! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'nk 8/31/2004 09:02'! noteInstalledPackageWithId: aPackageId autoVersion: aVersion name: aName "The package release was just successfully installed. Can be used to inform SM of an installation not been done using SM, even when the map isn't loaded. We record the fact in our Dictionary of installed packages and log a 'do it' to mark this in the changelog. The doit helps keeping track of the packages when recovering changes etc - not a perfect solution but should help. The map used is the default map. The id of the package is the key and the value is an OrderedCollection of Arrays with the release auto version, the point in time and the current installCounter." | time name id v | v := aVersion isString ifTrue: [aVersion asVersion] ifFalse: [aVersion]. aName ifNil: [name := ''] ifNotNil: [name := aName]. id := UUID fromString: aPackageId. time := Time totalSeconds. self countInstall. self markInstalled: id version: v time: time counter: installCounter. SmalltalkImage current logChange: '"Installed ' , name , ' auto version ' , v versionString , '". (Smalltalk at: #SMSqueakMap ifAbsent: []) ifNotNil:[ SMSqueakMap noteInstalledPackageWithId: ' , id asString storeString , ' autoVersion: ' , v storeString , ' atSeconds: ' , time asString , ' number: ' , installCounter asString , ']'! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/13/2004 02:39'! silentlyDo: aBlock "Execute with the Silent flag set. This is a crude way of avoiding user interaction during batch operations, like loading updates." [silent _ true. aBlock value] ensure: [silent _ nil]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 11/17/2003 13:06'! upgradeOldPackages "Upgrade all upgradeable old packages without confirmation on each." ^self upgradeOldPackagesConfirmBlock: [:package | true ]! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 16:26'! upgradeOldPackagesConfirmBlock: aBlock "First we find out which of the installed packages are upgradeable and old. Then we upgrade them if confirmation block yields true. The block will be called with each SMPackage to upgrade. We return a Dictionary with the packages we tried to upgrade as keys and the value being the result of the upgrade, true or false." | result | result _ Dictionary new. self upgradeableAndOldPackages do: [:package | (aBlock value: package) ifTrue:[ result at: package put: package upgrade]]. ^result ! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:33'! upgradeOrInstallPackage: aPackage "Upgrade package (or install) to the latest published release for this Squeak version." ^aPackage upgradeOrInstall! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:33'! upgradeOrInstallPackageWithId: anUUIDString "Upgrade package (or install) to the latest published release for this Squeak version." | package | package _ self packageWithId: anUUIDString. package ifNil: [self error: 'No package available with id: ''', anUUIDString, '''']. ^package upgradeOrInstall! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:16'! upgradePackage: aPackage "Upgrade package to the latest published release for this Squeak version." ^aPackage upgrade! ! !SMSqueakMap methodsFor: 'public-installation' stamp: 'gk 7/14/2004 17:30'! upgradePackageWithId: anUUIDString "Upgrade package to the latest published release for this Squeak version. Will raise error if there is no release installed, otherwise use #upgradeOrInstallPackageWithId: " | package | package _ self packageWithId: anUUIDString. package ifNil: [self error: 'No package available with id: ''', anUUIDString, '''']. ^package upgrade! ! !SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 11/18/2003 17:48'! markInstalled: uuid version: version time: time counter: num "Private. Mark the installation. SM2 uses an Association to distinguish the automatic version from old versions." | installs | installedPackages ifNil: [installedPackages _ Dictionary new]. installs _ installedPackages at: uuid ifAbsent: [installedPackages at: uuid put: OrderedCollection new]. installs add: (Array with: 2->version with: time with: num)! ! !SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 7/29/2003 01:33'! noteInstalledPackage: uuidString version: version "Mark a specific version of a package as installed. This method is called when replaying a logged installation from before SqueakMap 1.07. Such logged installations lacked a timestamp and a count. We take the current time and a count starting from -10000 and upwards. This should keep the sorting order correct." "Find the lowest installed count." | lowest | lowest _ 0. installedPackages ifNotNil: [ installedPackages valuesDo: [:oc | oc do: [:array | array last < lowest ifTrue: [lowest _ array last]]]] ifNil: [lowest _ -10000]. lowest negative ifFalse: [lowest _ -10000]. ^self noteInstalledPackage: uuidString version: version atSeconds: Time totalSeconds number: lowest + 1! ! !SMSqueakMap methodsFor: 'private-installation' stamp: 'gk 11/18/2003 17:54'! noteInstalledPackage: uuidString version: version atSeconds: time number: num "Mark a package as installed in the Dictionary. This method is called when replaying a logged installation.